├── .Rbuildignore ├── .github └── workflows │ ├── check-covr.yml │ └── pkgdown.yml ├── .gitignore ├── .lintr ├── DESCRIPTION ├── LICENSE ├── LICENSE.md ├── NAMESPACE ├── NEWS.md ├── R ├── ParameterSet.R ├── ParameterSet_S3methods.R ├── ParameterSet_helpers.R ├── ParameterSet_methods.R ├── cnd.R ├── helpers.R ├── prm.R ├── support_dictionary.R ├── tools.R └── zzz.R ├── README.Rmd ├── README.md ├── cran-comments.md ├── man-roxygen ├── param_prms.R ├── param_sort.R └── param_tag_properties.R ├── man ├── ParameterSet.Rd ├── as.ParameterSet.Rd ├── as.data.table.ParameterSet.Rd ├── as.prm.Rd ├── c.ParameterSet.Rd ├── cnd.Rd ├── cpset.Rd ├── expect_equal_ps.Rd ├── figures │ └── logo.png ├── length.ParameterSet.Rd ├── param6-package.Rd ├── prm.Rd ├── pset.Rd ├── rep.ParameterSet.Rd ├── sub-.ParameterSet.Rd └── support_dictionary.Rd ├── param6.Rproj ├── tests ├── .DS_Store ├── testthat.R └── testthat │ ├── .DS_Store │ ├── helpers.R │ ├── test-helpers.R │ ├── test-paramset.R │ └── test-prm.R └── todo ├── ParameterSet_helpers.R └── ParameterSet_methods.R /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^LICENSE\.md 2 | ^inst/data-raw$ 3 | ^tic\.R$ 4 | cran-comments\.md 5 | .ignore 6 | .editorconfig 7 | .gitignore 8 | ^.*\.Rproj$ 9 | ^\.Rproj\.user$ 10 | ^man-roxygen$ 11 | ^attic$ 12 | ^docs$ 13 | ^todo$ 14 | ^pkgdown$ 15 | inst/trigger-mlr3book.sh 16 | ^\.lintr$ 17 | ^README\.Rmd$ 18 | 19 | ^\.ccache$ 20 | ^\.github$ 21 | ^CRAN-RELEASE$ 22 | .vscode -------------------------------------------------------------------------------- /.github/workflows/check-covr.yml: -------------------------------------------------------------------------------- 1 | on: 2 | pull_request: 3 | branches: main 4 | schedule: 5 | - cron: "0 4 * * *" 6 | 7 | name: R-CMD-check 8 | 9 | jobs: 10 | R-CMD-check: 11 | runs-on: ${{ matrix.config.os }} 12 | 13 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 14 | 15 | strategy: 16 | fail-fast: false 17 | matrix: 18 | config: 19 | - {os: windows-latest, r: 'release'} 20 | - {os: ubuntu-20.04, r: 'devel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} 21 | - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} 22 | - {os: ubuntu-20.04, r: 'oldrel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} 23 | 24 | env: 25 | R_REMOTES_NO_ERRORS_FROM_WARNINGS: true 26 | RSPM: ${{ matrix.config.rspm }} 27 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 28 | 29 | steps: 30 | - uses: actions/checkout@v2 31 | 32 | - uses: r-lib/actions/setup-r@v1 33 | id: install-r 34 | with: 35 | r-version: ${{ matrix.config.r }} 36 | http-user-agent: ${{ matrix.config.http-user-agent }} 37 | 38 | - uses: r-lib/actions/setup-pandoc@v1 39 | 40 | - name: Install pak and query dependencies 41 | run: | 42 | install.packages("pak", repos = "https://r-lib.github.io/p/pak/dev/") 43 | saveRDS(pak::pkg_deps("local::.", dependencies = TRUE), ".github/r-depends.rds") 44 | shell: Rscript {0} 45 | 46 | - name: Restore R package cache 47 | uses: actions/cache@v2 48 | with: 49 | path: | 50 | ${{ env.R_LIBS_USER }}/* 51 | !${{ env.R_LIBS_USER }}/pak 52 | key: ${{ matrix.config.os }}-${{ steps.install-r.outputs.installed-r-version }}-1-${{ hashFiles('.github/r-depends.rds') }} 53 | restore-keys: ${{ matrix.config.os }}-${{ steps.install-r.outputs.installed-r-version }}-1- 54 | 55 | - name: Install system dependencies 56 | if: runner.os == 'Linux' 57 | run: | 58 | pak::local_system_requirements(execute = TRUE) 59 | pak::pkg_system_requirements("rcmdcheck", execute = TRUE) 60 | shell: Rscript {0} 61 | 62 | - name: Install dependencies 63 | run: | 64 | pak::local_install_dev_deps(upgrade = TRUE) 65 | pak::pkg_install("rcmdcheck") 66 | shell: Rscript {0} 67 | 68 | - name: Session info 69 | run: | 70 | options(width = 100) 71 | pkgs <- installed.packages()[, "Package"] 72 | sessioninfo::session_info(pkgs, include_base = TRUE) 73 | shell: Rscript {0} 74 | 75 | - name: Check 76 | env: 77 | _R_CHECK_CRAN_INCOMING_: false 78 | run: | 79 | options(crayon.enabled = TRUE) 80 | rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "warning", check_dir = "check") 81 | shell: Rscript {0} 82 | 83 | - name: Show testthat output 84 | if: always() 85 | run: find check -name 'testthat.Rout*' -exec cat '{}' \; || true 86 | shell: bash 87 | 88 | - name: Upload check results 89 | if: failure() 90 | uses: actions/upload-artifact@main 91 | with: 92 | name: ${{ matrix.config.os }}-r${{ matrix.config.r }}-results 93 | path: check 94 | 95 | - name: Don't use tar from old Rtools to store the cache 96 | if: ${{ runner.os == 'Windows' && startsWith(steps.install-r.outputs.installed-r-version, '3.6' ) }} 97 | shell: bash 98 | run: echo "C:/Program Files/Git/usr/bin" >> $GITHUB_PATH 99 | 100 | - name: Test coverage 101 | if: ${{ runner.os == 'Linux' && matrix.config.r == 'release'}} 102 | run: | 103 | install.packages('covr') 104 | covr::codecov() 105 | shell: Rscript {0} 106 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: main 4 | 5 | name: pkgdown 6 | 7 | jobs: 8 | pkgdown: 9 | runs-on: macOS-latest 10 | env: 11 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 12 | steps: 13 | - uses: actions/checkout@v2 14 | 15 | - uses: r-lib/actions/setup-r@master 16 | 17 | - uses: r-lib/actions/setup-pandoc@master 18 | 19 | - name: Query dependencies 20 | run: | 21 | install.packages('remotes') 22 | saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) 23 | writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") 24 | shell: Rscript {0} 25 | 26 | - name: Cache R packages 27 | uses: actions/cache@v1 28 | with: 29 | path: ${{ env.R_LIBS_USER }} 30 | key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} 31 | restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- 32 | 33 | - name: Install system dependencies 34 | run: brew install harfbuzz fribidi 35 | 36 | - name: Install dependencies 37 | run: | 38 | remotes::install_deps(dependencies = TRUE) 39 | install.packages(c("pkgdown", "textshaping")) 40 | shell: Rscript {0} 41 | 42 | - name: Install package 43 | run: R CMD INSTALL . 44 | 45 | - name: Deploy package 46 | run: | 47 | git config --local user.email "actions@github.com" 48 | git config --local user.name "GitHub Actions" 49 | Rscript -e 'pkgdown::deploy_to_branch(new_process = FALSE)' 50 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # History files 2 | .Rhistory 3 | .Rapp.history 4 | 5 | # Session Data files 6 | .RData 7 | 8 | # User-specific files 9 | .Ruserdata 10 | 11 | # Example code in package build process 12 | *-Ex.R 13 | 14 | # Output files from R CMD build 15 | /*.tar.gz 16 | 17 | # Output files from R CMD check 18 | /*.Rcheck/ 19 | 20 | # RStudio files 21 | .Rproj.user/ 22 | 23 | # produced vignettes 24 | vignettes/*.html 25 | vignettes/*.pdf 26 | 27 | # OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3 28 | .httr-oauth 29 | 30 | # knitr and R markdown default cache directories 31 | *_cache/ 32 | /cache/ 33 | 34 | # Temporary files created by R markdown 35 | *.utf8.md 36 | *.knit.md 37 | 38 | # R Environment Variables 39 | .Renviron 40 | 41 | .Rproj.user 42 | 43 | *.DS_Store 44 | docs/ 45 | .vscode 46 | */.DS_Store 47 | CRAN-RELEASE 48 | -------------------------------------------------------------------------------- /.lintr: -------------------------------------------------------------------------------- 1 | linters: with_defaults( 2 | object_name_linter = object_name_linter(c("snake_case", "CamelCase")), 3 | cyclocomp_linter = NULL) 4 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: param6 2 | Title: A Fast and Lightweight R6 Parameter Interface 3 | Description: By making use of 'set6', alongside the S3 and R6 paradigms, this package provides a fast and lightweight R6 interface for parameters and parameter sets. 4 | Version: 0.2.4 5 | Authors@R: 6 | person(given = "Raphael", 7 | family = "Sonabend", 8 | role = c("aut","cre"), 9 | email = "raphaelsonabend@gmail.com", 10 | comment = c(ORCID = "0000-0001-9225-4654")) 11 | License: MIT + file LICENSE 12 | URL: https://xoopR.github.io/param6/, https://github.com/xoopR/param6/ 13 | BugReports: https://github.com/xoopR/param6/issues 14 | Config/testthat/edition: 3 15 | Encoding: UTF-8 16 | NeedsCompilation: no 17 | Roxygen: list(markdown = TRUE, r6 = TRUE) 18 | RoxygenNote: 7.1.1 19 | Imports: 20 | checkmate, 21 | data.table, 22 | dictionar6 (>= 0.1.2), 23 | set6 (>= 0.2.3), 24 | R6 25 | Suggests: 26 | testthat 27 | Remotes: 28 | xoopR/set6 29 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2021 2 | COPYRIGHT HOLDER: Raphael Sonabend -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # MIT License 2 | 3 | Copyright (c) 2021 Raphael Sonabend 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method("[",ParameterSet) 4 | S3method(as.ParameterSet,data.table) 5 | S3method(as.ParameterSet,list) 6 | S3method(as.ParameterSet,prm) 7 | S3method(as.data.table,ParameterSet) 8 | S3method(as.prm,ParameterSet) 9 | S3method(as.prm,data.table) 10 | S3method(c,ParameterSet) 11 | S3method(length,ParameterSet) 12 | S3method(rep,ParameterSet) 13 | export(ParameterSet) 14 | export(as.ParameterSet) 15 | export(as.prm) 16 | export(cnd) 17 | export(cpset) 18 | export(expect_equal_ps) 19 | export(prm) 20 | export(pset) 21 | export(support_dictionary) 22 | import(R6) 23 | import(dictionar6) 24 | import(set6) 25 | importFrom(data.table,":=") 26 | importFrom(data.table,as.data.table) 27 | importFrom(data.table,data.table) 28 | importFrom(stats,setNames) 29 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # param6 0.2.4 2 | 3 | * Added conditions for increasing and decreasing parameters 4 | * Fixed bug that meant multiple conditions weren't being checked 5 | 6 | # param6 0.2.3 7 | 8 | * Patch for testthat 9 | 10 | # param6 0.2.2 11 | 12 | * Fixes bug in `.update_support` where duplicated items were being added to the support dictionary 13 | 14 | # param6 0.2.1 15 | 16 | * expect_equal_ps is now more precise 17 | * cpset now much faster 18 | * empty tags now stored as list() not NULL 19 | * extract method is now more efficient, removed 'keep_trafo' argument 20 | * can now remove multiple ids with $remove 21 | 22 | # param6 0.2.0 23 | 24 | * Bugfix in `expand_list` which was causing parameter names to be swapped 25 | * Bugfix in testing linked parameters 26 | * Added sets containing zero (e.g. PosReals$new(zero = TRUE)) to the support dictionary 27 | * Add parameters to `pset` to simplify construction with deps and trafo 28 | * Now support parameters being required and linked simultaneously. Exactly one parameter in a required/linked group must be set. 29 | * Added 'immutable' property for parameters that can be set on construction then cannot be changed 30 | * Renamed 'ExtendedReals' to 'ExtReals' 31 | * Minor internal bug fixes 32 | * Transformations now support in replication and extraction 33 | * Added method to update parameter supports 34 | * Added method to remove parmameters from constructed sets 35 | 36 | # param6 0.1.1 37 | 38 | * Bug fix in extracting parameters from sets without tags 39 | * Allow option to stop `Dictionary` deep cloning R6 objects 40 | 41 | # param6 0.1.0 42 | 43 | * Initial upload to CRAN. 44 | -------------------------------------------------------------------------------- /R/ParameterSet.R: -------------------------------------------------------------------------------- 1 | #' @title Parameter Set 2 | #' @description `ParameterSet` objects store parameters ([prm] objects) and add 3 | #' internal validation checks and methods for: 4 | #' 5 | #' * Getting and setting parameter values 6 | #' * Transforming parameter values 7 | #' * Providing dependencies of parameters on each other 8 | #' * Tagging parameters, which may enable further properties 9 | #' * Storing subsets of parameters under prefixes 10 | #' 11 | #' @examples 12 | #' library(set6) 13 | #' 14 | #' ## $value examples 15 | #' p <- ParameterSet$new(list(prm(id = "a", support = Reals$new()))) 16 | #' p$values$a <- 2 17 | #' p$values 18 | #' 19 | #' ## $trafo examples 20 | #' p <- ParameterSet$new(list(prm(id = "a", 2, support = Reals$new()))) 21 | #' p$trafo 22 | #' 23 | #' # simple transformation 24 | #' p$get_values() 25 | #' p$trafo <- function(x, self) { 26 | #' x$a <- exp(x$a) 27 | #' x 28 | #' } 29 | #' p$get_values() 30 | #' 31 | #' # more complex transformation on tags 32 | #' p <- ParameterSet$new( 33 | #' list(prm(id = "a", 2, support = Reals$new(), tags = "t1"), 34 | #' prm(id = "b", 3, support = Reals$new(), tags = "t1"), 35 | #' prm(id = "d", 4, support = Reals$new())) 36 | #' ) 37 | #' # make sure `transform = FALSE` to prevent infinite recursion 38 | #' p$trafo <- function(x, self) { 39 | #' out <- lapply(self$get_values(tags = "t1", transform = FALSE), 40 | #' function(.x) 2^.x) 41 | #' out <- c(out, list(d = x$d)) 42 | #' out 43 | #' } 44 | #' p$get_values() 45 | #' 46 | #' @template param_prms 47 | #' @template param_tag_properties 48 | #' @template param_sort 49 | #' @export 50 | ParameterSet <- R6::R6Class("ParameterSet", 51 | public = list( 52 | #' @description Constructs a `ParameterSet` object. 53 | #' @examples 54 | #' prms <- list( 55 | #' prm("a", Set$new(1), 1, tags = "t1"), 56 | #' prm("b", "reals", 1.5, tags = "t1"), 57 | #' prm("d", "reals", 2, tags = "t2") 58 | #' ) 59 | #' ParameterSet$new(prms) 60 | initialize = function(prms = list(), tag_properties = NULL) { 61 | .ParameterSet__initialize(self, private, prms, tag_properties) 62 | }, 63 | 64 | #' @description Prints the `ParameterSet` after coercion with 65 | #' [as.data.table.ParameterSet]. 66 | #' @examples 67 | #' prms <- list( 68 | #' prm("a", Set$new(1), 1, tags = "t1"), 69 | #' prm("b", "reals", 1.5, tags = "t1"), 70 | #' prm("d", "reals", 2, tags = "t2") 71 | #' ) 72 | #' p <- ParameterSet$new(prms) 73 | #' p$print() 74 | #' print(p) 75 | #' p 76 | print = function(sort = TRUE) .ParameterSet__print(self, private, sort), 77 | 78 | #' @description Gets values from the `ParameterSet` with options to filter 79 | #' by specific IDs and tags, and also to transform the values. 80 | #' @param id (`character()`) \cr 81 | #' If not NULL then returns values for given `ids`. 82 | #' @param tags (`character()`) \cr 83 | #' If not NULL then returns values for given `tags`. 84 | #' @param transform (`logical(1)`) \cr 85 | #' If `TRUE` (default) and `$trafo` is not `NULL` then runs the set 86 | #' transformation function before returning the values. 87 | #' @param inc_null (`logical(1)`) \cr 88 | #' If `TRUE` (default) then returns values for all ids even if `NULL`. 89 | #' @param simplify (`logical(1)`) \cr 90 | #' If `TRUE` (default) then unlists scalar values, otherwise always 91 | #' returns a list. 92 | #' @examples 93 | #' prms <- list( 94 | #' prm("a", "reals", 1, tags = "t1"), 95 | #' prm("b", "reals", 1.5, tags = "t1"), 96 | #' prm("d", "reals", tags = "t2") 97 | #' ) 98 | #' p <- ParameterSet$new(prms) 99 | #' p$trafo <- function(x, self) { 100 | #' x$a <- exp(x$a) 101 | #' x 102 | #' } 103 | #' p$get_values() 104 | #' p$get_values(inc_null = FALSE) 105 | #' p$get_values(id = "a") 106 | #' p$get_values(tags = "t1") 107 | get_values = function(id = NULL, tags = NULL, transform = TRUE, 108 | inc_null = TRUE, simplify = TRUE) { 109 | .ParameterSet__get_values(self, private, id, tags, transform, inc_null, 110 | simplify) 111 | }, 112 | 113 | #' @description Gets values from the `ParameterSet` with options to filter 114 | #' by specific IDs and tags, and also to transform the values. 115 | #' @param id (`character(1)`) \cr 116 | #' The dependent variable for the condition that depends on the given 117 | #' variable, `on`, being a particular value. Should be in `self$ids`. 118 | #' @param on (`character(1)`) \cr 119 | #' The independent variable for the condition that is depended on by the 120 | #' given variable, `id`. Should be in `self$ids`. 121 | #' @param cnd (`cnd(1)`) \cr 122 | #' The condition defined by [cnd] which determines how `id` depends on `on`. 123 | #' @examples 124 | #' # not run as errors 125 | #' \dontrun{ 126 | #' # Dependency on specific value 127 | #' prms <- list( 128 | #' prm("a", "reals", NULL), 129 | #' prm("b", "reals", 1) 130 | #' ) 131 | #' p <- ParameterSet$new(prms) 132 | #' p$add_dep("a", "b", cnd("eq", 2)) 133 | #' # 'a' can only be set if 'b' equals 2 134 | #' p$values$a <- 1 135 | #' p$values <- list(a = 1, b = 2) 136 | #' 137 | #' # Dependency on variable value 138 | #' prms <- list( 139 | #' prm("a", "reals", NULL), 140 | #' prm("b", "reals", 1) 141 | #' ) 142 | #' p <- ParameterSet$new(prms) 143 | #' p$add_dep("a", "b", cnd("eq", id = "b")) 144 | #' # 'a' can only be set if it equals 'b' 145 | #' p$values$a <- 2 146 | #' p$values <- list(a = 2, b = 2) 147 | #' } 148 | add_dep = function(id, on, cnd) { 149 | .ParameterSet__add_dep(self, private, id, on, cnd) 150 | }, 151 | 152 | #' @description Replicate the `ParameterSet` with identical parameters. 153 | #' In order to avoid duplicated parameter ids, every id in the 154 | #' `ParameterSet` is given a `prefix` in the format `prefix__id`. In 155 | #' addition, linked tags are also given the same prefix to prevent 156 | #' incorrectly linking parameters. 157 | #' 158 | #' The primary use-case of this method is to treat the `ParameterSet` as a 159 | #' collection of identical `ParameterSet` objects. 160 | #' 161 | #' Note that this mutates the `ParameterSet`, if you want to instead create 162 | #' a new object then use [rep.ParameterSet] instead (or copy and deep clone) 163 | #' first. 164 | #' @param times (`integer(1)`) \cr 165 | #' Numer of times to replicate the `ParameterSet`. 166 | #' @param prefix (`character(1)|character(length(times))`) \cr 167 | #' The prefix to add to ids and linked tags. If length `1` then is 168 | #' internally coerced to `paste0(prefix, seq(times))`, otherwise the length 169 | #' should be equal to `times`. 170 | rep = function(times, prefix) { 171 | .ParameterSet__rep(self, private, times, prefix) 172 | }, 173 | 174 | #' @description Creates a new `ParameterSet` by extracting the given 175 | #' parameters. 176 | #' @param id (`character()`) \cr 177 | #' If not `NULL` then specifies the parameters by id to extract. Should be 178 | #' `NULL` if `prefix` is not `NULL`. 179 | #' @param tags (`character()`) \cr 180 | #' If not `NULL` then specifies the parameters by tag to extract. Should be 181 | #' `NULL` if `prefix` is not `NULL`. 182 | #' @param prefix (`character()`) \cr 183 | #' If not `NULL` then extracts parameters according to their prefix and 184 | #' additionally removes the prefix from the id. A prefix is determined as 185 | #' the string before `"__"` in an id. 186 | #' 187 | #' @examples 188 | #' # extract by id 189 | #' prms <- list( 190 | #' prm("a", "reals", NULL), 191 | #' prm("b", "reals", 1) 192 | #' ) 193 | #' p <- ParameterSet$new(prms) 194 | #' p$extract("a") 195 | #' # equivalently 196 | #' p["a"] 197 | #' 198 | #' # extract by prefix 199 | #' prms <- list( 200 | #' prm("Pre1__par1", Set$new(1), 1, tags = "t1"), 201 | #' prm("Pre1__par2", "reals", 3, tags = "t2"), 202 | #' prm("Pre2__par1", Set$new(1), 1, tags = "t1"), 203 | #' prm("Pre2__par2", "reals", 3, tags = "t2") 204 | #' ) 205 | #' p <- ParameterSet$new(prms) 206 | #' p$extract(tags = "t1") 207 | #' p$extract(prefix = "Pre1") 208 | #' # equivalently 209 | #' p[prefix = "Pre1"] 210 | extract = function(id = NULL, tags = NULL, prefix = NULL) { 211 | .ParameterSet__extract(self, private, id, tags, prefix) 212 | }, 213 | 214 | 215 | #' @description Removes the given parameters from the set. 216 | #' @param id (`character()`) \cr 217 | #' If not `NULL` then specifies the parameters by id to extract. Should be 218 | #' `NULL` if `prefix` is not `NULL`. 219 | #' @param prefix (`character()`) \cr 220 | #' If not `NULL` then extracts parameters according to their prefix and 221 | #' additionally removes the prefix from the id. A prefix is determined as 222 | #' the string before `"__"` in an id. 223 | remove = function(id = NULL, prefix = NULL) { 224 | .ParameterSet__remove(self, private, id, prefix) 225 | }, 226 | 227 | #' @description Deprecated method added for distr6 compatibility. 228 | #' Use $values/$get_values() in the future. 229 | #' Will be removed in 0.3.0. 230 | #' @param id Parameter id 231 | #' @param ... Unused 232 | getParameterValue = function(id, ...) { 233 | # nocov start 234 | warning("Deprecated. In the future please use $values/$get_values(). Will be removed in 0.3.0.") # nolint 235 | self$get_values(id) 236 | # nocov end 237 | }, 238 | 239 | #' @description Deprecated method added for distr6 compatibility. 240 | #' Use $set_values in the future. 241 | #' Will be removed in 0.3.0. 242 | #' @param ... Parameter ids 243 | #' @param lst List of parameter ids 244 | setParameterValue = function(..., lst = list(...)) { 245 | # nocov start 246 | warning("Deprecated. In the future please use $values. Will be removed in 0.3.0.") # nolint 247 | self$values <- unique_nlist(c(lst, self$values)) 248 | # nocov end 249 | }, 250 | 251 | #' @description Convenience function for setting multiple parameters 252 | #' without changing or accidentally removing others. 253 | #' @param ... Parameter ids 254 | #' @param lst List of parameter ids 255 | set_values = function(..., lst = list(...)) { 256 | self$values <- unique_nlist(c(lst, self$values)) 257 | invisible(self) 258 | }, 259 | 260 | #' @description Deprecated method added for distr6 compatibility. 261 | #' Use $print/as.data.table() in the future. 262 | #' Will be removed in 0.3.0. 263 | #' @param ... Unused 264 | parameters = function(...) { 265 | # nocov start 266 | warning("Deprecated. In the future please use $print/as.data.table(). Will be removed in 0.3.0.") # nolint 267 | self 268 | # nocov end 269 | }, 270 | 271 | #' @description Applies the internal transformation function. 272 | #' If no function has been passed to `$trafo` then `x` is returned 273 | #' unchanged. If `$trafo` is a function then `x` is passed directly to 274 | #' this. If `$trafo` is a list then `x` is evaluated and passed down the 275 | #' list iteratively. 276 | #' @param x (`named list(1)`) \cr 277 | #' List of values to transform. 278 | #' @return `named list(1)` 279 | transform = function(x = self$values) { 280 | .ParameterSet__transform(self, private, x) 281 | } 282 | ), 283 | 284 | active = list( 285 | #' @field tags None -> `named_list()` \cr 286 | #' Get tags from the parameter set. 287 | tags = function() private$.tags, 288 | 289 | #' @field ids None -> `character()` \cr 290 | #' Get ids from the parameter set. 291 | ids = function() private$.id, 292 | 293 | #' @field length None -> `integer(1)` \cr 294 | #' Get the length of the parameter set as the number of parameters. 295 | length = function() length(self$ids), 296 | 297 | #' @field deps None -> [data.table::data.table] 298 | #' Get parameter dependencies, NULL if none. 299 | deps = function() private$.deps, 300 | 301 | #' @field supports None -> `named_list()` \cr 302 | #' Get supports from the parameter set. 303 | supports = function() .ParameterSet__supports(self, private), 304 | 305 | #' @field tag_properties `list() -> self` / None -> `list()` \cr 306 | #' If `x` is missing then returns tag properties if any. \cr 307 | #' If `x` is not missing then used to tag properties. Currently properties 308 | #' can either be: \cr 309 | #' i) 'required' - parameters with this tag must have set (non-NULL) 310 | #' values; if a parameter is both 'required' and 'linked' then exactly 311 | #' one parameter in the 'linked' tag must be tagged;\cr 312 | #' ii) 'linked' - parameters with 'linked' tags are dependent on one another 313 | #' and only one can be set (non-NULL at a time);\cr 314 | #' iii) 'unique' - parameters with this tag must have no duplicated 315 | #' elements, therefore this tag only makes sense for vector parameters;\cr 316 | #' iv) 'immutable' - parameters with this tag cannot be updated after 317 | #' construction. 318 | tag_properties = function(x) { 319 | .ParameterSet__tag_properties(self, private, x) 320 | }, 321 | 322 | #' @field values `list() -> self` / None -> `list()` \cr 323 | #' If `x` is missing then returns the set (non-NULL) values without 324 | #' transformation or filtering; use `$get_values` for a more sophisticated 325 | #' getter of values. \cr 326 | #' If `x` is not missing then used to set values of parameters, which are 327 | #' first checked internally with the `$check` method before setting the new 328 | #' values. \cr 329 | #' See examples at end. 330 | values = function(x) .ParameterSet__values(self, private, x), 331 | 332 | #' @field trafo `function()|list() -> self` / None -> `function()|list()` 333 | #' \cr 334 | #' If `x` is missing then returns a transformation function if previously 335 | #' set, a list of transformation functions, otherwise `NULL`. \cr 336 | #' If `x` is not missing then it should either be: 337 | #' 338 | #' * a function with arguments `x` and `self`, which internally correspond 339 | #' to `self` being the `ParameterSet` the transformation is being added to, 340 | #' and `x <- self$values`. 341 | #' * a list of functions like above 342 | #' 343 | #' The transformation function is automatically called after a call to 344 | #' `self$get_values()` and is used to transform set values, it should 345 | #' therefore result in a list. If using `self$get_values()` within the 346 | #' transformation function, make sure to set `transform = FALSE` to prevent 347 | #' infinite recursion, see examples at end. 348 | #' 349 | #' It is generally safer to call the transformation with 350 | #' `$transform(self$values)` as this will first check to see if `$trafo` 351 | #' is a function or list. If the latter then each function in the list is 352 | #' applied, one after the other. 353 | trafo = function(x) .ParameterSet__trafo(self, private, x) 354 | ), 355 | 356 | private = list( 357 | .id = NULL, 358 | .isupports = NULL, 359 | .supports = NULL, 360 | .value = NULL, 361 | .tags = NULL, 362 | .tag_properties = NULL, 363 | .trafo = NULL, 364 | .deps = NULL, 365 | .immutable = NULL, 366 | ## update support of given prm 367 | .update_support = function(..., lst = list(...)) { 368 | .ParameterSet__.update_support(self, private, lst) 369 | }, 370 | ## adds given prefix to ids in all private fields 371 | .prefix = function(prefix) { 372 | .ParameterSet__.prefix(self, private, prefix) 373 | }, 374 | ## removes given prefix to ids in all private fields 375 | .unprefix = function(prefix) { 376 | .ParameterSet__.unprefix(self, private, prefix) 377 | }, 378 | deep_clone = function(name, value) { 379 | switch(name, 380 | ".deps" = { 381 | if (!is.null(value)) { 382 | data.table::copy(value) 383 | } 384 | }, 385 | value 386 | ) 387 | } 388 | ) 389 | ) 390 | 391 | #' @title Convenience Function for Constructing a ParameterSet 392 | #' @description See [ParameterSet] for full details. 393 | #' @param ... ([prm]) \cr [prm] objects. 394 | #' @param prms (`list()`) \cr List of [prm] objects. 395 | #' @template param_tag_properties 396 | #' @param deps (`list()`) \cr List of lists where each element is passed to 397 | #' `$add_dep`. See examples. 398 | #' @param trafo (`function()`) \cr Passed to `$trafo`. See examples. 399 | #' @examples 400 | #' library(set6) 401 | #' 402 | #' # simple example 403 | #' prms <- list( 404 | #' prm("a", Set$new(1), 1, tags = "t1"), 405 | #' prm("b", "reals", 1.5, tags = "t1"), 406 | #' prm("d", "reals", 2, tags = "t2") 407 | #' ) 408 | #' p <- pset(prms = prms) 409 | #' 410 | #' # with properties, deps, trafo 411 | #' p <- pset( 412 | #' prm("a", Set$new(1), 1, tags = "t1"), 413 | #' prm("b", "reals", 1.5, tags = "t1"), 414 | #' prm("d", "reals", 2, tags = "t2"), 415 | #' tag_properties = list(required = "t2"), 416 | #' deps = list( 417 | #' list(id = "a", on = "b", cond = cnd("eq", 1.5)) 418 | #' ), 419 | #' trafo = function(x, self) return(x) 420 | #' ) 421 | #' @export 422 | pset <- function(..., prms = list(...), tag_properties = NULL, deps = NULL, 423 | trafo = NULL) { 424 | 425 | ps <- ParameterSet$new(prms, tag_properties) 426 | 427 | if (!is.null(deps)) { 428 | checkmate::assert_list(deps) 429 | lapply(deps, function(x) { 430 | cnd <- if (checkmate::test_list(x$cond)) x$cond[[1]] else x$cond 431 | ps$add_dep(x$id, x$on, cnd) 432 | }) 433 | } 434 | 435 | ps$trafo <- trafo 436 | 437 | ps 438 | } 439 | -------------------------------------------------------------------------------- /R/ParameterSet_S3methods.R: -------------------------------------------------------------------------------- 1 | #' @title Coercions to ParameterSet 2 | #' @param x (`ANY`) \cr Object to coerce. 3 | #' @param ... (`ANY`) \cr Other arguments passed to [ParameterSet], such as 4 | #' `tag_properties`. 5 | #' @export 6 | as.ParameterSet <- function(x, ...) { # nolint 7 | UseMethod("as.ParameterSet") 8 | } 9 | 10 | #' @rdname as.ParameterSet 11 | #' @export 12 | as.ParameterSet.data.table <- function(x, ...) { # nolint 13 | ParameterSet$new(as.prm(x), ...) 14 | } 15 | 16 | #' @rdname as.ParameterSet 17 | #' @export 18 | as.ParameterSet.prm <- function(x, ...) { # nolint 19 | ParameterSet$new(list(x), ...) 20 | } 21 | 22 | #' @rdname as.ParameterSet 23 | #' @export 24 | as.ParameterSet.list <- function(x, ...) { # nolint 25 | checkmate::assert_list(x, "prm", any.missing = FALSE) 26 | pset(prms = x, ...) 27 | } 28 | 29 | #' @title Length of a ParameterSet 30 | #' @description Gets the number of parameters in the [ParameterSet]. 31 | #' @param x ([ParameterSet]) 32 | #' @export 33 | length.ParameterSet <- function(x) { 34 | x$length 35 | } 36 | 37 | #' @title Replicate a ParameterSet 38 | #' @description In contrast to the `$rep` method in [ParameterSet], this method 39 | #' deep clones the [ParameterSet] and returns a new object. 40 | #' @details In order to avoid duplicated parameter ids, every id in the 41 | #' [ParameterSet] is given a `prefix` in the format `prefix__id`. In 42 | #' addition, linked tags are also given the same prefix to prevent 43 | #' incorrectly linking parameters. 44 | #' 45 | #' The primary use-case of this method is to treat the [ParameterSet] as a 46 | #' collection of identical [ParameterSet] objects. 47 | #' 48 | #' @param x ([ParameterSet]) 49 | #' @param times (`integer(1)`) \cr 50 | #' Numer of times to replicate the `ParameterSet`. 51 | #' @param prefix (`character(1)|character(length(times))`) \cr 52 | #' The prefix to add to ids and linked tags. If length `1` then is 53 | #' internally coerced to `paste0(prefix, seq(times))`, otherwise the length 54 | #' should be equal to `times`. 55 | #' @param ... (`ANY`) \cr Other arguments, currently unused. 56 | #' @export 57 | rep.ParameterSet <- function(x, times, prefix, ...) { 58 | x <- x$clone(deep = TRUE) 59 | x$rep(times, prefix) 60 | x 61 | } 62 | 63 | #' @title Concatenate Unique ParameterSet Objects 64 | #' @description Concatenate multiple [ParameterSet] objects with unique ids and 65 | #' tags into a single [ParameterSet]. 66 | #' @details Concatenates ids, tags, tag properties and dependencies. Assumes 67 | #' ids and tags are unique; trafos are combined into a list. 68 | #' @param ... ([ParameterSet]s) \cr [ParameterSet] objects to concatenate. 69 | #' @param pss (`list()`) \cr Alternatively pass a list of [ParameterSet] 70 | #' objects. 71 | #' @export 72 | c.ParameterSet <- function(..., pss = list(...)) { 73 | .combine_unique(pss) 74 | } 75 | 76 | 77 | #' @title Concatenate ParameterSet Objects 78 | #' @description Concatenate multiple [ParameterSet] objects into a single 79 | #' [ParameterSet]. 80 | #' @details Concatenates ids, tags, tag properties and dependencies, 81 | #' but not transformations. 82 | #' @param ... ([ParameterSet]s) \cr Named [ParameterSet] objects to concatenate. 83 | #' @param pss (`named list()`) \cr Alternatively pass a named list of 84 | #' [ParameterSet] objects. 85 | #' @param clone (`logical(1)`) \cr If `TRUE` (default) parameter sets are deep 86 | #' cloned before combination, useful to prevent original sets being prefixed. 87 | #' @export 88 | cpset <- function(..., pss = list(...), clone = TRUE) { 89 | 90 | checkmate::assert_list(pss, names = "unique") 91 | 92 | pss <- lapply(seq_along(pss), function(i) { 93 | .x <- pss[[i]] 94 | if (clone) { 95 | .x <- .x$clone(deep = TRUE) 96 | } 97 | get_private(.x)$.prefix(names(pss)[[i]]) 98 | }) 99 | 100 | .combine_unique(pss) 101 | } 102 | 103 | .combine_unique <- function(pss) { 104 | 105 | pnew <- pset() 106 | pri <- get_private(pnew) 107 | pri$.id <- unlist(rlapply(pss, "ids"), TRUE, FALSE) 108 | pri$.supports <- unlist(rlapply(pss, ".supports")) 109 | pri$.isupports <- invert_names(pri$.supports) 110 | pri$.value <- unlist(rlapply(pss, "values"), FALSE) 111 | pri$.tags <- unlist(rlapply(pss, ".tags"), FALSE) 112 | 113 | trafo <- drop_null(rlapply(pss, "trafo")) 114 | if (length(trafo)) { 115 | trafo <- trafo[!duplicated(trafo)] 116 | if (length(trafo) == 1 && is.null(names(trafo))) { 117 | trafo <- trafo[[1]] 118 | } 119 | pri$.trafo <- trafo 120 | } 121 | 122 | deps <- drop_null(rlapply(pss, ".deps")) 123 | if (length(deps) == 1) { 124 | pri$.deps <- deps[[1]] 125 | } else if (length(deps) > 1) { 126 | pri$.deps <- do.call(rbind, deps) 127 | } 128 | 129 | imm <- unlist(rlapply(pss, ".immutable"), FALSE) 130 | if (length(imm)) { 131 | pri$.immutable <- imm 132 | } 133 | 134 | props <- unlist(rlapply(pss, ".tag_properties"), FALSE) 135 | if (length(props)) { 136 | tprop <- list() 137 | tprop$required <- unique(unlist(list_element(props, "required"))) 138 | tprop$linked <- unique(unlist(list_element(props, "linked"))) 139 | tprop$unique <- unique(unlist(list_element(props, "unique"))) 140 | tprop$immutable <- unique(unlist(list_element(props, "immutable"))) 141 | 142 | if (any(duplicated(unlist(tprop)))) { 143 | stop("Cannot merge inconsistent tag properties.") 144 | } 145 | 146 | pri$.tag_properties <- tprop 147 | } 148 | 149 | pnew 150 | } 151 | 152 | #' @title Coerce a ParameterSet to a data.table 153 | #' @description Coercion from [ParameterSet] to [data.table::data.table]. 154 | #' Dependencies, transformations, and tag properties are all lost in 155 | #' coercion. 156 | #' @param x ([ParameterSet]) 157 | #' @param sort (`logical(1)`) \cr If `TRUE`(default) sorts the [ParameterSet] 158 | #' alphabetically by id. 159 | #' @param ... (`ANY`) \cr Other arguments, currently unused. 160 | #' @export 161 | as.data.table.ParameterSet <- function(x, sort = TRUE, ...) { # nolint 162 | if (length(x$ids) == 0) { 163 | return(data.table(Id = character(0), Support = list(), Value = list(), 164 | Tags = character(0))) 165 | } 166 | 167 | if (length(x$deps) || length(get_private(x)$.trafo)) { 168 | warning("Dependencies and trafos are lost in coercion.") 169 | } 170 | 171 | vals <- expand_list(x$ids, x$values) 172 | tags <- expand_list(x$ids, x$tags) 173 | 174 | dt <- data.table::data.table( 175 | Id = x$ids, 176 | Support = x$supports, 177 | Value = vals[match(names(vals), x$ids)], 178 | Tags = tags[match(names(tags), x$ids)] 179 | ) 180 | if (sort) { 181 | Id <- NULL # binding fix 182 | data.table::setorder(dt, Id) 183 | } 184 | dt 185 | } 186 | 187 | #' @title Extract a sub-ParameterSet by Parameters 188 | #' @description Creates a new [ParameterSet] by extracting the given 189 | #' parameters. S3 method for the `$extract` public method. 190 | #' @param object ([ParameterSet]) 191 | #' @param ... (`ANY`) \cr Passed to [ParameterSet]$extract 192 | #' @export 193 | `[.ParameterSet` <- function(object, ...) { 194 | object$extract(...) 195 | } 196 | -------------------------------------------------------------------------------- /R/ParameterSet_helpers.R: -------------------------------------------------------------------------------- 1 | .filter_field <- function(self, x, id = NULL, tags = NULL, inc_null = TRUE, 2 | simplify = FALSE) { 3 | 4 | if (inc_null) { 5 | x <- expand_list(self$ids, x) 6 | } 7 | 8 | tagx <- idx <- named_list() 9 | 10 | if (!is.null(tags)) { 11 | which <- names(self$tags)[(grepl(paste0(tags, collapse = "|"), self$tags))] 12 | tagx <- x[match(which, names(x), 0L)] 13 | } 14 | 15 | if (!is.null(id)) { 16 | nid <- id 17 | ## match start on prefix 18 | mtc <- grepl("__", id) 19 | nid[mtc] <- sprintf("^%s", nid[mtc]) 20 | 21 | ## match postfix otherwise 22 | nid[!mtc] <- sprintf("(__%s$)|(^%s$)", nid[!mtc], nid[!mtc]) 23 | 24 | nid <- paste0(sprintf("(%s)", nid), collapse = "|") 25 | mtc <- grepl(nid, names(x)) 26 | idx <- x[mtc] 27 | } 28 | 29 | if (!is.null(tags) || !is.null(id)) { 30 | x <- unique_nlist(c(idx, tagx)) 31 | } 32 | 33 | if (simplify) { 34 | if (length(x) == 0) { 35 | x <- NULL 36 | } else if (length(x) == 1) { 37 | x <- x[[1]] 38 | } 39 | } 40 | 41 | x 42 | } 43 | 44 | .get_values <- function(self, private, values, id = NULL, tags = NULL, 45 | transform = TRUE, inc_null = TRUE, simplify = TRUE) { 46 | 47 | if (transform) { 48 | values <- self$transform() 49 | } 50 | 51 | .filter_field(self, values, id, tags, inc_null, simplify) 52 | } 53 | 54 | .check <- function(self, private, supports = TRUE, deps = TRUE, 55 | tags = TRUE, id = NULL, error_on_fail = TRUE, 56 | value_check = NULL, support_check = NULL, dep_check = NULL, 57 | tag_check = NULL, transform = TRUE) { 58 | 59 | x <- TRUE 60 | 61 | if (transform) { 62 | trafo_value_check <- self$transform(value_check) 63 | } else { 64 | trafo_value_check <- value_check 65 | } 66 | 67 | 68 | # 1. Containedness checks 69 | if (supports && length(self)) { 70 | imm_rm <- NULL 71 | if ("immutable" %in% self$tag_properties) { 72 | imm_rm <- names(self$get_values( 73 | tags = self$tag_properties["immutable"], 74 | simplify = FALSE, 75 | transform = FALSE 76 | )) 77 | } 78 | x <- .check_supports( 79 | self, 80 | trafo_value_check[names(trafo_value_check) %nin% imm_rm], 81 | support_check, id, error_on_fail) 82 | } 83 | 84 | if (!x) { 85 | return(FALSE) 86 | } 87 | 88 | # 2. Dependencies 89 | if (deps && !is.null(dep_check)) { 90 | x <- .check_deps(self, trafo_value_check, dep_check, id, error_on_fail) 91 | } 92 | 93 | if (!x) { 94 | return(FALSE) 95 | } 96 | 97 | # 3. Tags 98 | if (tags && !is.null(tag_check)) { 99 | x <- .check_tags(self, value_check, tag_check, id, error_on_fail) 100 | } 101 | 102 | if (!x) { 103 | return(FALSE) 104 | } else { 105 | return(TRUE) 106 | } 107 | } 108 | 109 | .check_supports <- function(self, values, supports, id, error_on_fail) { 110 | if (length(values)) { 111 | for (i in seq_along(supports)) { 112 | ids <- supports[[i]] 113 | 114 | if (!is.null(id)) { 115 | ids <- intersect(id, ids) 116 | cvalues <- values[intersect(ids, names(values))] 117 | } else { 118 | cvalues <- values 119 | } 120 | 121 | if (!length(cvalues) || !length(ids)) { 122 | next 123 | } 124 | 125 | value <- .get_values(self, get_private(self), cvalues, 126 | inc_null = FALSE, simplify = FALSE, 127 | transform = FALSE 128 | ) 129 | 130 | 131 | set <- support_dictionary$get(names(supports)[[i]]) 132 | 133 | if (!set$contains(value, all = TRUE)) { 134 | return(.return_fail( 135 | msg = sprintf( 136 | "One or more of %s does not lie in %s.", 137 | string_as_set(value), as.character(set) 138 | ), 139 | error_on_fail 140 | )) 141 | } 142 | } 143 | } 144 | 145 | TRUE 146 | } 147 | 148 | .check_deps <- function(self, values, deps, id, error_on_fail) { 149 | 150 | if (!is.null(deps) && nrow(deps)) { 151 | for (i in seq(nrow(deps))) { 152 | id <- deps[i, 1][[1]] 153 | on <- deps[i, 2][[1]] 154 | cnd <- deps[i, 3][[1]][[1]] 155 | fun <- eval(cnd) 156 | id_value <- .get_values(self, get_private(self), values, id, 157 | transform = FALSE, inc_null = FALSE 158 | ) 159 | 160 | if (length(id_value)) { 161 | if (on != "") { 162 | on_value <- .get_values(self, get_private(self), values, on, 163 | transform = FALSE, inc_null = FALSE 164 | ) 165 | ok <- fun(on_value, id_value) 166 | } else { 167 | ok <- fun(id_value) 168 | } 169 | 170 | if (!ok) { 171 | if (!is.null(attr(cnd, "error"))) { 172 | msg <- attr(cnd, "error") 173 | } else { 174 | if (on == "") { 175 | msg <- sprintf("'%s' is not %s.", id, attr(cnd, "type")) 176 | } else { 177 | if (!is.null(attr(cnd, "id"))) { 178 | msg <- sprintf( 179 | "Dependency of '%s %s %s' failed.", 180 | id, attr(cnd, "type"), on 181 | ) 182 | } else { 183 | msg <- sprintf( 184 | "Dependency of %s on '%s %s %s' failed.", id, on, 185 | attr(cnd, "type"), string_as_set(attr(cnd, "value")) 186 | ) 187 | } 188 | } 189 | } 190 | return(.return_fail( 191 | msg = msg, 192 | error_on_fail 193 | )) 194 | } 195 | } 196 | } 197 | } 198 | 199 | return(TRUE) 200 | } 201 | 202 | .check_tags <- function(self, values, tags, id, error_on_fail) { 203 | 204 | if (length(tags)) { 205 | # required tag 206 | if (length(tags$required)) { 207 | vals <- .filter_field(self, values, NULL, tags = tags[["required"]]) 208 | null_vals <- vals[vapply(vals, is.null, logical(1))] 209 | 210 | if (length(null_vals)) { 211 | if (length(tags$linked)) { 212 | nok <- any(vapply( 213 | tags$linked, 214 | function(.x) all(names(self$tags)[ 215 | grepl(.x, self$tags)] %in% names(null_vals)), 216 | logical(1) 217 | )) 218 | } else { 219 | nok <- TRUE 220 | } 221 | } else { 222 | nok <- FALSE 223 | } 224 | 225 | if (nok) { 226 | return(.return_fail( 227 | msg = "Not all required parameters are set.", 228 | error_on_fail 229 | )) 230 | } 231 | } 232 | 233 | # linked tag 234 | if (length(tags$linked)) { 235 | vals <- .get_values(self, get_private(self), values, NULL, 236 | tags[["linked"]], FALSE, inc_null = FALSE, 237 | simplify = FALSE) 238 | if (any(grepl("__", names(vals), fixed = TRUE))) { 239 | nok <- any(vapply(get_prefix(names(vals)), function(i) { 240 | length(vals[grepl(sprintf("^%s__", i), names(vals))]) > 241 | length(tags[["linked"]]) 242 | }, logical(1))) 243 | } else { 244 | nok <- length(vals) > length(tags[["linked"]]) 245 | } 246 | 247 | if (nok) { 248 | return(.return_fail( 249 | msg = "Multiple linked parameters are set.", 250 | error_on_fail 251 | )) 252 | } 253 | } 254 | 255 | # unique tag 256 | if (length(tags$unique)) { 257 | vals <- .get_values(self, get_private(self), values, NULL, 258 | tags = tags[["unique"]], 259 | inc_null = FALSE, simplify = FALSE, 260 | transform = FALSE) 261 | nok <- any(vapply(vals, function(i) any(duplicated(i)), logical(1))) 262 | if (nok) { 263 | return(.return_fail( 264 | msg = "One or more unique parameters are duplicated.", 265 | error_on_fail 266 | )) 267 | } 268 | } 269 | } 270 | 271 | return(TRUE) 272 | } 273 | 274 | assert_no_cycles <- function(lookup) { 275 | check <- data.table::data.table(lookup[, 2]) 276 | checks <- data.table::data.table(lookup[, 1]) 277 | 278 | for (i in seq_len(ncol(lookup))) { 279 | check <- merge(check, lookup, by.x = "on", by.y = "id", sort = FALSE)[, 2] 280 | colnames(check) <- "on" 281 | checks <- cbind(checks, check) 282 | 283 | checker <- apply(checks, 1, function(x) any(duplicated(x)) & !any(is.na(x))) 284 | if (any(checker)) { 285 | stop(sprintf("Cycles detected starting from id(s): %s", 286 | paste0("{", paste0(checks$id[checker], 287 | collapse = ","), "}"))) 288 | } 289 | 290 | 291 | } 292 | } 293 | 294 | assert_condition <- function(id, support, cond) { 295 | if (is.null(attr(cond, "id"))) { 296 | val <- attr(cond, "value") 297 | if (attr(cond, "type") %in% c("==", ">=", "<=", ">", "<", "%in%")) { 298 | msg <- sprintf("%s does not lie in support of %s (%s). Condition is not possible.", # nolint 299 | val, id, as.character(support)) 300 | } else if (attr(cond, "type") != "len") { 301 | msg <- sprintf("%s does not lie in support of %s (%s). Condition is redundant.", # nolint 302 | val, id, as.character(support)) 303 | } 304 | 305 | if (!is.null(support$power) && support$power == "n") { 306 | val <- as.Tuple(val) 307 | } 308 | 309 | if (!(testContains(support, val))) { 310 | stop(msg) 311 | } 312 | } 313 | 314 | invisible(cond) 315 | } 316 | 317 | .return_fail <- function(msg, error_on_fail) { 318 | if (error_on_fail) { 319 | stop(msg) 320 | } else { 321 | warning(msg) 322 | return(FALSE) 323 | } 324 | } 325 | 326 | .assert_tag_properties <- function(prop, utags, self) { 327 | add_tag_prop <- function(what) { 328 | if (what %in% utags) { 329 | if (is.null(prop)) { 330 | prop <- list(what) 331 | names(prop) <- what 332 | } else { 333 | if (is.null(prop[[what]])) { 334 | prop[[what]] <- what 335 | } else { 336 | if (what %nin% prop[[what]]) { 337 | prop[[what]] <- c(prop[[what]], what) 338 | } 339 | } 340 | } 341 | } 342 | prop 343 | } 344 | 345 | prop <- add_tag_prop("required") 346 | prop <- add_tag_prop("linked") 347 | prop <- add_tag_prop("unique") 348 | prop <- add_tag_prop("immutable") 349 | 350 | if (!is.null(prop)) { 351 | checkmate::assert_list(prop, names = "unique") 352 | checkmate::assert_subset(unlist(prop), utags) 353 | checkmate::assert_subset(names(prop), 354 | c("required", "linked", "unique", "immutable")) 355 | .check_tags(self, self$values, prop, NULL, TRUE) 356 | } 357 | 358 | invisible(prop) 359 | 360 | } 361 | -------------------------------------------------------------------------------- /R/ParameterSet_methods.R: -------------------------------------------------------------------------------- 1 | #--------------- 2 | # Public Methods 3 | #--------------- 4 | 5 | .ParameterSet__initialize <- function(self, private, prms, tag_properties) { # nolint 6 | 7 | if (length(prms)) { 8 | checkmate::assert_list(prms, "prm", any.missing = FALSE) 9 | prms <- unname(prms) 10 | 11 | ids <- vapply(prms, "[[", character(1), "id") 12 | if (any(duplicated(ids))) { 13 | stop("ids are not unique.") 14 | } else { 15 | names(prms) <- ids 16 | private$.id <- ids 17 | } 18 | 19 | private$.supports <- vapply(prms, "[[", character(1), "support") 20 | private$.isupports <- invert_names(private$.supports) 21 | 22 | private$.value <- un_null_list(lapply(prms, "[[", "value")) 23 | 24 | tag_list <- un_null_list(lapply(prms, "[[", "tags")) 25 | if (length(tag_list)) { 26 | private$.tags <- tag_list 27 | private$.tag_properties <- 28 | .assert_tag_properties(tag_properties, unique(unlist(tag_list)), self) 29 | 30 | if ("immutable" %in% private$.tag_properties) { 31 | private$.immutable <- self$get_values( 32 | tags = self$tag_properties["immutable"], simplify = FALSE 33 | ) 34 | } 35 | 36 | if (any(duplicated(c(private$.id, unique(unlist(private$.tags)))))) { 37 | stop("ids and tags must have different names.") 38 | } 39 | } else { 40 | private$.tags <- list() 41 | } 42 | } else { 43 | private$.value <- list() 44 | private$.id <- list() 45 | private$.tags <- list() 46 | } 47 | 48 | invisible(self) 49 | } 50 | 51 | .ParameterSet__print <- function(self, private, sort) { # nolint 52 | dt <- suppressWarnings(as.data.table(self, sort = sort)) 53 | if (nrow(dt)) { 54 | dt$Support <- vapply(dt$Support, function(x) x$strprint(), character(1)) 55 | } 56 | print(dt) 57 | } 58 | 59 | .ParameterSet__get_values <- function(self, private, id, tags, transform, # nolint 60 | inc_null, simplify) { 61 | .get_values(self, private, private$.value, id, tags, transform, inc_null, 62 | simplify) 63 | } 64 | 65 | .ParameterSet__add_dep <- function(self, private, id, on, cnd) { # nolint 66 | checkmate::assert_class(cnd, "cnd") 67 | all_ids <- unique(c(self$ids, unprefix(self$ids))) 68 | checkmate::assert_subset(id, all_ids) 69 | checkmate::assert_subset(on, all_ids) 70 | 71 | if (!is.null(attr(cnd, "id"))) { 72 | checkmate::assert_choice(attr(cnd, "id"), on) 73 | } 74 | 75 | if (is.null(self$deps)) { 76 | deps <- data.table(id = character(0L), on = character(0L), 77 | cond = list()) 78 | } else { 79 | deps <- self$deps 80 | } 81 | 82 | if (!is.null(on)) { 83 | if (id == on) { 84 | stop("Parameters cannot depend on themselves.") 85 | } 86 | 87 | # hacky fix 88 | aid <- id 89 | aon <- on 90 | 91 | nok <- !is.null(private$.deps) && 92 | nrow(subset(private$.deps, grepl(aid, id) & grepl(aon, on))) 93 | if (nok) { 94 | stop(sprintf("%s already depends on %s.", id, on)) 95 | } 96 | 97 | support <- unique( 98 | unlist(private$.supports[grepl(on, names(private$.supports))])) 99 | 100 | support <- support_dictionary$get(support) 101 | 102 | new_dt <- rbind( 103 | deps, 104 | data.table(id = id, on = on, 105 | cond = list(assert_condition(on, support, cnd)))) 106 | 107 | assert_no_cycles(new_dt) 108 | } else { 109 | new_dt <- rbind( 110 | deps, 111 | data.table(id = id, on = "", cond = list(cnd)), 112 | fill = TRUE 113 | ) 114 | } 115 | 116 | .check_deps(self, self$values, new_dt, id, TRUE) 117 | 118 | private$.deps <- new_dt 119 | 120 | invisible(self) 121 | } 122 | 123 | .ParameterSet__rep <- function(self, private, times, prefix) { # nolint 124 | 125 | if (length(prefix) == 1) { 126 | prefix <- paste0(prefix, seq_len(times)) 127 | } else if (length(prefix) != times) { 128 | stop(sprintf("'prefix' should either be length '1' or same as 'times' (%d)", times)) # nolint 129 | } 130 | 131 | assert_alphanum(prefix) 132 | 133 | lng <- length(self) 134 | 135 | private$.id <- paste(rep(prefix, each = lng), rep(private$.id), 136 | sep = "__") 137 | 138 | private$.isupports <- lapply(private$.isupports, 139 | function(x) paste(rep(prefix, 140 | each = length(x)), 141 | rep(x, times), sep = "__")) 142 | 143 | private$.supports <- rep(private$.supports, times) 144 | names(private$.supports) <- paste(rep(prefix, each = lng), 145 | names(private$.supports), sep = "__") 146 | 147 | values <- rep(private$.value, times) 148 | names(values) <- paste(rep(prefix, each = length(private$.value)), 149 | names(values), sep = "__") 150 | private$.value <- values 151 | 152 | tags <- rep(private$.tags, times) 153 | names(tags) <- paste(rep(prefix, each = length(private$.tags)), 154 | names(tags), sep = "__") 155 | private$.tags <- tags 156 | 157 | if (!is.null(private$.immutable)) { 158 | imm <- rep(private$.immutable, times) 159 | names(imm) <- paste(rep(prefix, each = length(private$.immutable)), 160 | names(imm), sep = "__") 161 | private$.immutable <- imm 162 | } 163 | 164 | invisible(self) 165 | } 166 | 167 | .ParameterSet__extract <- function(self, private, id, tags, prefix) { # nolint 168 | 169 | if (is.null(id) && is.null(prefix) && is.null(tags)) { 170 | stop("One argument must be non-NULL.") 171 | } else if ((!is.null(id) || !is.null(tags)) && !is.null(prefix)) { 172 | stop("'prefix' must be NULL if 'id' or 'tags' is non-NULL") 173 | } 174 | 175 | if (!is.null(prefix)) { 176 | ids <- names(.filter_field(self, private$.value, 177 | sprintf("^%s__", assert_alphanum(prefix)))) 178 | } else { 179 | ids <- names(.filter_field(self, private$.value, id, tags)) 180 | } 181 | 182 | rm_ids <- setdiff(self$ids, ids) 183 | 184 | ## create new parameterset 185 | pnew <- self$clone(deep = TRUE) 186 | ## remove non-extracted ids 187 | pnew$remove(rm_ids) 188 | 189 | ## remove prefix if required 190 | if (!is.null(prefix)) { 191 | get_private(pnew)$.unprefix(prefix) 192 | } 193 | 194 | pnew 195 | } 196 | 197 | 198 | .ParameterSet__remove <- function(self, private, id, prefix) { # nolint 199 | 200 | if (sum(is.null(id) + is.null(prefix)) != 1) { 201 | stop("Exactly one argument must be non-NULL.") 202 | } 203 | 204 | if (!is.null(prefix)) { 205 | stopifnot(length(prefix) == 1) 206 | pars <- self$ids[grepl(prefix, get_prefix(self$ids))] 207 | } else { 208 | pars <- id 209 | } 210 | 211 | if (setequal(pars, self$ids)) { 212 | stop("Can't remove all parameters") 213 | } 214 | 215 | mtc_pars <- paste0(pars, collapse = "|") 216 | 217 | private$.immutable[pars] <- NULL 218 | if (length(private$.immutable) == 0) { 219 | private$.immutable <- NULL 220 | } 221 | if (!is.null(private$.deps)) { 222 | private$.deps <- private$.deps[!(id %in% pars | on %in% pars), ] 223 | if (nrow(private$.deps) == 0) { 224 | private$.deps <- NULL 225 | } 226 | } 227 | 228 | if (is.list(private$.trafo)) { 229 | private$.trafo[c(prefix, pars)] <- NULL 230 | if (length(private$.trafo) == 0) { 231 | private$.trafo <- NULL 232 | } else if (checkmate::test_list(private$.trafo, len = 1) && 233 | (is.null(names(private$.trafo)) || names(private$.trafo) == "")) { 234 | private$.trafo <- private$.trafo[[1]] 235 | } 236 | } 237 | 238 | private$.tags[pars] <- NULL 239 | if (length(private$.tags) == 0) { 240 | private$.tags <- list() 241 | private$.tag_properties <- NULL 242 | } 243 | 244 | ## TODO: Consider adding removal of tag property 245 | 246 | private$.value[pars] <- NULL 247 | if (length(private$.value) == 0) { 248 | private$.value <- list() 249 | } 250 | private$.supports <- private$.supports[setdiff(names(private$.supports), 251 | pars)] 252 | 253 | which <- grepl(mtc_pars, private$.isupports) 254 | private$.isupports[which] <- lapply(private$.isupports[which], 255 | function(.x) setdiff(.x, pars)) 256 | private$.isupports <- drop_null(private$.isupports) 257 | 258 | private$.id <- setdiff(private$.id, pars) 259 | 260 | invisible(self) 261 | } 262 | 263 | 264 | .ParameterSet__transform <- function(self, private, x) { # nolint 265 | 266 | trafo <- self$trafo 267 | if (is.null(trafo)) { 268 | return(x) 269 | } 270 | 271 | if (checkmate::test_function(trafo)) { 272 | x <- trafo(x, self) 273 | } else { 274 | if (is.null(nms <- names(trafo))) { 275 | for (i in seq_along(trafo)) { 276 | x <- trafo[[i]](x, self) 277 | } 278 | } else { 279 | newx <- x[!grepl(paste0(sprintf("%s__", nms), collapse = "|"), names(x))] 280 | for (i in seq_along(trafo)) { 281 | ## if unnamed then apply to all 282 | if (is.na(nms[[i]]) || nms[[i]] == "") { 283 | newx <- append(newx, trafo[[i]](x, self)) 284 | } else { 285 | which <- grepl(sprintf("%s__", nms[[i]]), names(x)) 286 | newx <- append(newx, trafo[[i]](x[which], self)) 287 | } 288 | } 289 | x <- newx 290 | } 291 | } 292 | 293 | x 294 | } 295 | 296 | 297 | #--------------- 298 | # Active Bindings 299 | #--------------- 300 | 301 | .ParameterSet__supports <- function(self, private) { # nolint 302 | sups <- support_dictionary$get_list(private$.supports) 303 | names(sups) <- self$ids 304 | sups 305 | } 306 | 307 | .ParameterSet__tag_properties <- function(self, private, x) { # nolint 308 | if (missing(x)) { 309 | private$.tag_properties 310 | } else { 311 | private$.tag_properties <- 312 | .assert_tag_properties(x, unlist(self$tags), self) 313 | invisible(self) 314 | } 315 | } 316 | 317 | .ParameterSet__values <- function(self, private, x) { # nolint 318 | 319 | if (missing(x)) { 320 | return(sort_named_list(private$.value)) 321 | } else { 322 | x <- un_null_list(x) 323 | bad_nms <- names(x) %nin% self$ids 324 | if (any(bad_nms)) { 325 | stop( 326 | sprintf("You can't set ids that don't exist in the parameter set: %s", 327 | string_as_set(names(x)[bad_nms])) 328 | ) 329 | } 330 | if (length(x)) { 331 | .check(self, private, 332 | id = names(x), value_check = x, 333 | support_check = private$.isupports, dep_check = self$deps, 334 | tag_check = self$tag_properties 335 | ) 336 | } else if (!is.null(self$tag_properties) && 337 | "required" %in% names(self$tag_properties)) { 338 | stop("Not all required parameters are set") 339 | } else if (!is.null(self$tag_properties) && 340 | "immutable" %in% names(self$tag_properties)) { 341 | stop("Immutable parameters cannot be updated after construction") 342 | } 343 | which <- intersect(names(private$.immutable), names(x)) 344 | x[which] <- private$.immutable[which] 345 | x <- c(x, private$.immutable[names(private$.immutable) %nin% names(x)]) 346 | private$.value <- x 347 | invisible(self) 348 | } 349 | } 350 | 351 | .ParameterSet__trafo <- function(self, private, x) { # nolint 352 | 353 | if (missing(x)) { 354 | private$.trafo 355 | } else { 356 | if (length(x)) { 357 | if (checkmate::test_list(x)) { 358 | x <- unlist(x, recursive = FALSE) 359 | if (!is.null(names(x))) { 360 | names(x) <- gsub(".", "__", names(x), fixed = TRUE) 361 | } 362 | x <- x[!duplicated(x)] 363 | lapply(x, checkmate::assert_function, args = c("x", "self"), 364 | ordered = TRUE) 365 | if (length(x) == 1 && (is.null(names(x)) || is.na(names(x)))) { 366 | x <- x[[1]] 367 | } 368 | } else { 369 | checkmate::assert_function(x, args = c("x", "self"), TRUE) 370 | } 371 | } else { 372 | x <- NULL 373 | } 374 | 375 | otrafo <- private$.trafo 376 | private$.trafo <- x 377 | vals <- checkmate::assert_list(self$transform(self$values)) 378 | 379 | tryCatch(.check(self, private, id = names(vals), value_check = vals, 380 | support_check = private$.isupports, 381 | dep_check = self$deps, transform = FALSE), 382 | error = function(e) { 383 | private$.trafo <- otrafo 384 | stop(e) 385 | }) 386 | 387 | invisible(self) 388 | } 389 | } 390 | 391 | 392 | #--------------- 393 | # Private Methods 394 | #--------------- 395 | .ParameterSet__.update_support <- function(self, private, x) { # nolint 396 | ## get sets as strings 397 | strs <- vapply(x, as.character, character(1), n = Inf) 398 | 399 | ## add to dictionary as required 400 | miss <- !support_dictionary$has(strs) 401 | if (any(miss)) { 402 | uni <- !duplicated(strs[miss]) 403 | support_dictionary$add(setNames(x[miss][uni], strs[miss][uni])) 404 | } 405 | 406 | ## update supports 407 | private$.supports[names(x)] <- strs 408 | private$.isupports <- invert_names(private$.supports) 409 | 410 | invisible(self) 411 | } 412 | 413 | 414 | .ParameterSet__.prefix <- function(self, private, prefix) { # nolint 415 | 416 | private$.id <- give_prefix(self$ids, prefix) 417 | private$.immutable <- prefix_list(private$.immutable, prefix) 418 | private$.tags <- prefix_list(private$.tags, prefix) 419 | private$.value <- prefix_list(private$.value, prefix) 420 | private$.supports <- prefix_list(private$.supports, prefix) 421 | private$.isupports <- invert_names(private$.supports) 422 | 423 | if (is.list(private$.trafo)) { 424 | private$.trafo <- prefix_list(private$.trafo, prefix) 425 | } 426 | 427 | if (length(private$.deps)) { 428 | private$.deps[, id := give_prefix(id, prefix)] 429 | private$.deps[, on := give_prefix(on, prefix)] 430 | private$.deps$cond <- lapply(private$.deps$cond, function(.x) { 431 | at <- attr(.x, "id") 432 | if (!is.null(at)) { 433 | attr(.x, "id") <- give_prefix(at, prefix) 434 | } 435 | .x 436 | }) 437 | } 438 | 439 | 440 | if (length(private$.tag_properties) && 441 | "linked" %in% names(private$.tag_properties)) { 442 | tags <- private$.tag_properties$linked 443 | private$.tag_properties$linked <- 444 | give_prefix(private$.tag_properties$linked, prefix) 445 | which <- grepl(paste0(tags, collapse = "|"), private$.tags) 446 | if (any(which)) { 447 | for (i in seq_along(private$.tags[which])) { 448 | iwhich <- private$.tags[which][[i]] %in% tags 449 | private$.tags[which][[i]][iwhich] <- 450 | give_prefix(private$.tags[which][[i]][iwhich], prefix) 451 | } 452 | } 453 | } 454 | 455 | invisible(self) 456 | } 457 | 458 | 459 | .ParameterSet__.unprefix <- function(self, private, prefix) { # nolint 460 | 461 | private$.id <- unprefix(self$ids) 462 | private$.immutable <- unprefix_list(private$.immutable) 463 | private$.tags <- unprefix_list(private$.tags) 464 | private$.value <- unprefix_list(private$.value) 465 | private$.supports <- unprefix_list(private$.supports) 466 | private$.isupports <- invert_names(private$.supports) 467 | 468 | if (is.list(private$.trafo)) { 469 | private$.trafo <- unprefix_list(private$.trafo) 470 | } 471 | 472 | if (length(private$.deps)) { 473 | private$.deps[, id := unprefix(id)] 474 | private$.deps[, on := unprefix(on)] 475 | private$.deps$cond <- lapply(private$.deps$cond, function(.x) { 476 | at <- attr(.x, "id") 477 | if (!is.null(at)) { 478 | attr(.x, "id") <- unprefix(at) 479 | } 480 | .x 481 | }) 482 | } 483 | 484 | 485 | if (length(private$.tag_properties) && 486 | "linked" %in% names(private$.tag_properties)) { 487 | tags <- private$.tag_properties$linked 488 | private$.tag_properties$linked <- 489 | unprefix(private$.tag_properties$linked) 490 | which <- private$.tags %in% tags 491 | if (any(which)) { 492 | for (i in seq_along(private$.tags[which])) { 493 | iwhich <- private$.tags[which][[i]] %in% tags 494 | private$.tags[which][[i]][[iwhich]] <- 495 | unprefix(private$.tags[which][[i]][[iwhich]]) 496 | } 497 | } 498 | } 499 | 500 | invisible(self) 501 | } 502 | -------------------------------------------------------------------------------- /R/cnd.R: -------------------------------------------------------------------------------- 1 | #' @title Create a ParameterSet Condition 2 | #' @description Function to create a condition for [ParameterSet] dependencies 3 | #' for use in the `$deps` public method. 4 | #' @param type (`character(1)`) \cr 5 | #' The condition `type` determines the type of dependency to create, options 6 | #' are given in details. 7 | #' @param value (`ANY`) \cr 8 | #' If `id` is `NULL` then `value` should be a value in the support of the 9 | #' parameter that the condition is testing, that will be passed to the 10 | #' condition determined by `type`. Can be left NULL if testing if 11 | #' increasing/decreasing. 12 | #' @param id (`character(1)`) \cr 13 | #' If `value` is `NULL` then `id` should be the same as the id that the 14 | #' condition is testing, and the condition then takes the currently set value 15 | #' of the id in its argument. Can be left NULL if testing if 16 | #' increasing/decreasing. 17 | #' @param error (`character(1)`) \cr 18 | #' Optional error message to be displayed on fail. 19 | #' @details 20 | #' This function should never be used outside of creating a condition for 21 | #' a dependency in a [ParameterSet]. Currently the following conditions are 22 | #' supported based on the `type` argument, we refer to the parameter depended 23 | #' on as in the independent parameter, and the other as the dependent: 24 | #' 25 | #' * `"eq"` - If `value` is not `NULL` then checks if the independent parameter 26 | #' equals `value`, otherwise checks if the independent and dependent parameter 27 | #' are equal. 28 | #' * `"neq"` - If `value` is not `NULL` then checks if the independent 29 | #' parameter does not equal `value`, otherwise checks if the independent and 30 | #' dependent parameter are not equal. 31 | #' * `"gt"/"lt"` - If `value` is not `NULL` then checks if the independent 32 | #' parameter is greater/less than `value`, otherwise checks if the independent 33 | #' parameter is greater/less than the dependent parameter. 34 | #' * `"geq"/"leq"` - If `value` is not `NULL` then checks if the independent 35 | #' parameter is greater/less than or equal to `value`, otherwise checks if the 36 | #' independent parameter is greater/less than or equal to the dependent 37 | #' parameter. 38 | #' * `"any"` - If `value` is not `NULL` then checks if the independent 39 | #' parameter equals any of `value`, otherwise checks if the independent 40 | #' parameter equals any of dependent parameter. 41 | #' * `"nany"` - If `value` is not `NULL` then checks if the independent 42 | #' parameter does not equal any of `value`, otherwise checks if the independent 43 | #' parameter does not equal any of dependent parameter. 44 | #' * `"len"` - If `value` is not `NULL` then checks if the length of the 45 | #' independent parameter equals `value`, otherwise checks if the independent 46 | #' and dependent parameter are the same length. 47 | #' * `"inc"` - Checks if the parameter is increasing. 48 | #' * `"sinc"` - Checks if the parameter is strictly increasing. 49 | #' * `"dec"` - Checks if the parameter is decreasing. 50 | #' * `"sdec"` - Checks if the parameter is strictly decreasing. 51 | #' @export 52 | cnd <- function(type, value = NULL, id = NULL, error = NULL) { 53 | choice <- c("eq", "neq", "geq", "leq", "gt", "lt", "any", "nany", "len", 54 | "inc", "sinc", "dec", "sdec") 55 | sfun <- switch(type, 56 | "eq" = `==`, 57 | "neq" = `!=`, 58 | "geq" = `>=`, 59 | "leq" = `<=`, 60 | "gt" = `>`, 61 | "lt" = `<`, 62 | "any" = `%in%`, 63 | "nany" = `%nin%`, 64 | "len" = { 65 | if (!is.null(id)) { 66 | function(x, y) length(x) == length(y) 67 | } else { 68 | function(x, y) length(x) == y 69 | } 70 | }, 71 | "inc" = function(x, ...) all(diff(x) >= 0), 72 | "sinc" = function(x, ...) all(diff(x) > 0), 73 | "dec" = function(x, ...) all(diff(x) <= 0), 74 | "sdec" = function(x, ...) all(diff(x) < 0), 75 | stop(sprintf("'type' must be one of %s.", string_as_set(choice))) 76 | ) 77 | 78 | if (!is.null(id)) { 79 | if (!is.null(value)) { 80 | warning("'id' and 'value' are non-NULL, 'value' is ignored.") 81 | } 82 | fun <- substitute(function(on, idx, ...) { 83 | !any(is.null(on)) && all(sfun(unlist(idx), unlist(on))) 84 | }) 85 | } else { 86 | fun <- substitute(function(x, ...) { 87 | if (is.list(x) && is.null(value)) { 88 | !any(is.null(x)) && all(vapply(x, sfun, logical(1))) 89 | } else { 90 | !any(is.null(x)) && all(sfun(unlist(x), value)) 91 | } 92 | }) 93 | } 94 | 95 | char <- switch(type, 96 | "eq" = "==", 97 | "neq" = "!=", 98 | "geq" = ">=", 99 | "leq" = "<=", 100 | "gt" = ">", 101 | "lt" = "<", 102 | "any" = "%in%", 103 | "nany" = "%nin%", 104 | "len" = "len", 105 | "inc" = "increasing", 106 | "sinc" = "strictly increasing", 107 | "dec" = "decreasing", 108 | "sdec" = "strictly decreasing" 109 | ) 110 | 111 | class(fun) <- "cnd" 112 | attr(fun, "value") <- value 113 | attr(fun, "id") <- id 114 | attr(fun, "type") <- char 115 | attr(fun, "error") <- error 116 | fun 117 | } 118 | -------------------------------------------------------------------------------- /R/helpers.R: -------------------------------------------------------------------------------- 1 | assert_contains <- function(set, value, name) { 2 | if (set$contains(value, all = TRUE)) { 3 | invisible(value) 4 | } else { 5 | if (!missing(name)) { 6 | stop(sprintf("%s does not lie in support of %s (%s).", value, name, 7 | as.character(set))) 8 | } else { 9 | stop(sprintf("%s does not lie in %s.", value, as.character(set))) 10 | } 11 | } 12 | } 13 | 14 | string_as_set <- function(str) { 15 | if (!is.null(str)) { 16 | paste0("{", paste0(str, collapse = ", "), "}") 17 | } 18 | } 19 | 20 | sort_named_list <- function(lst, ...) { 21 | if (length(lst)) { 22 | lst[order(names(lst), ...)] 23 | } else { 24 | lst 25 | } 26 | } 27 | 28 | named_list <- function(values, names) { 29 | if (missing(values) && missing(names)) { 30 | setNames(list(), character()) 31 | } else { 32 | setNames(list(values), names) 33 | } 34 | } 35 | 36 | as_named_list <- function(values, names) { 37 | if (missing(values) && missing(names)) { 38 | setNames(list(), character()) 39 | } else { 40 | setNames(as.list(values), names) 41 | } 42 | } 43 | 44 | expand_list <- function(names, named_var) { 45 | checkmate::assert_character(names) 46 | checkmate::assert_list(named_var) 47 | 48 | mtc <- match(names(named_var), names) 49 | if (any(is.na(mtc))) { 50 | stop("ids in 'names' not in 'named_var'") 51 | } 52 | 53 | x <- setNames(vector("list", length(names)), names) 54 | x[mtc] <- named_var 55 | x 56 | } 57 | 58 | get_private <- function(x) { 59 | x$.__enclos_env__$private 60 | } 61 | 62 | invert_names <- function(x) { 63 | uvalues <- unique(x) 64 | inv_x <- lapply(uvalues, function(.x) names(x)[x == .x]) 65 | names(inv_x) <- uvalues 66 | inv_x 67 | } 68 | 69 | # if results in empty list and rm.names = TRUE then unnames 70 | un_null_list <- function(x, rm.names = TRUE) { 71 | x[vapply(x, is.null, logical(1))] <- NULL 72 | if (!length(x)) { 73 | x <- unname(x) 74 | } 75 | x 76 | } 77 | 78 | # append and assign a variable in an environment 79 | env_append <- function(env, var, values) { 80 | env[[var]] <- c(env[[var]], values) 81 | invisible(NULL) 82 | } 83 | 84 | `%nin%` <- function(x, table) { 85 | !(x %in% table) 86 | } 87 | 88 | unprefix <- function(x, split = "__") { 89 | gsub(sprintf("([[:alnum:]]+)%s(\\S*)", split), "\\2", x) 90 | } 91 | 92 | get_prefix <- function(x) { 93 | gsub("([[:alnum:]]+)__(\\S*)", "\\1", x) 94 | } 95 | 96 | unique_nlist <- function(x) { 97 | x[!duplicated(names(x))] 98 | } 99 | 100 | 101 | drop_null <- function(x) { 102 | x[vapply(x, function(.x) length(.x) > 0, logical(1))] 103 | } 104 | 105 | 106 | assert_alphanum <- function(x) { 107 | if (any(grepl("[^[:alnum:]]", x))) { 108 | stop("'x' must be alphanumeric") 109 | } 110 | invisible(x) 111 | } 112 | 113 | list_element <- function(x, name) { 114 | x[grepl(name, names(x))] 115 | } 116 | 117 | 118 | give_prefix <- function(x, prefix) { 119 | sprintf("%s__%s", prefix, x) 120 | } 121 | 122 | 123 | prefix_list <- function(x, prefix) { 124 | if (length(x)) { 125 | setNames(x, give_prefix(names(x), prefix)) 126 | } else { 127 | x 128 | } 129 | } 130 | 131 | 132 | unprefix_list <- function(x) { 133 | if (length(x)) { 134 | setNames(x, unprefix(names(x))) 135 | } else { 136 | x 137 | } 138 | } 139 | 140 | 141 | rlapply <- function(x, fun) { 142 | if (startsWith(fun, ".")) { 143 | lapply(x, function(.x) get_private(.x)[[fun]]) 144 | } else { 145 | lapply(x, "[[", fun) 146 | } 147 | } 148 | -------------------------------------------------------------------------------- /R/prm.R: -------------------------------------------------------------------------------- 1 | #' @title S3 Parameter Constructor 2 | #' @description The `prm` class is required for [ParameterSet] objects, it 3 | #' allows specifying a parameter as a named set and optionally setting values 4 | #' and tags. 5 | #' @param id (`character(1)`) \cr 6 | #' Parameter identifier. 7 | #' @param support `([set6::Set]|character(1))` \cr 8 | #' Either a set object from 9 | #' \CRANpkg{set6} or a character representing the set if it is already present 10 | #' in the [support_dictionary]. If a [set6::Set] is provided then the set and 11 | #' its string representation are added automatically to [support_dictionary] 12 | #' in order to provide fast internal checks. Common sets (such as the reals, 13 | #' naturals, etc.) are already provided in [support_dictionary]. 14 | #' @param value `ANY` \cr 15 | #' Optional to assign the parameter, will internally 16 | #' be checked that it lies within the given support. 17 | #' @param tags (`character()`) \cr 18 | #' An optional character vector of tags to apply to the parameter. On their own 19 | #' tags offer little extra benefit, however they can be assigned properties 20 | #' when creating [ParameterSet] objects that enable them to be more powerful. 21 | #' @param .check For internal use only. 22 | #' @examples 23 | #' library(set6) 24 | #' 25 | #' # Constructing a prm with a Set support 26 | #' prm( 27 | #' id = "a", 28 | #' support = Reals$new(), 29 | #' value = 1 30 | #' ) 31 | #' 32 | #' # Constructing a prm with a support already in the dictionary 33 | #' prm( 34 | #' id = "a", 35 | #' support = "reals", 36 | #' value = 1 37 | #' ) 38 | #' 39 | #' # Adding tags 40 | #' prm( 41 | #' id = "a", 42 | #' support = "reals", 43 | #' value = 1, 44 | #' tags = c("tag1", "tag2") 45 | #' ) 46 | #' @export 47 | prm <- function(id, support, value = NULL, tags = NULL, .check = TRUE) { 48 | 49 | checkmate::assert_character(id, len = 1) 50 | if (id == "c") { 51 | stop("'c' is a reserved id in param6.") 52 | } 53 | 54 | # if character, check to see if exists in dictionary otherwise error 55 | if (checkmate::test_character(support, len = 1)) { 56 | if (!support_dictionary$has(support)) { 57 | stop("'support' given as character but does not exist in support_dictionary.") # nolint 58 | } 59 | str_support <- support 60 | support <- support_dictionary$get(str_support) 61 | # if Set, check to see if exists in dictionary otherwise add and return string 62 | } else if (checkmate::test_class(support, "Set")) { 63 | str_support <- as.character(support) 64 | if (!support_dictionary$has(str_support)) { 65 | orig_uni <- set6::useUnicode() 66 | set6::useUnicode(FALSE) 67 | support_dictionary$add(keys = str_support, values = support) 68 | set6::useUnicode(orig_uni) 69 | } 70 | } else { 71 | stop("'support' should be given as a character scalar or Set.") 72 | } 73 | 74 | if (!is.null(tags)) { 75 | tags <- unique(checkmate::assert_character(tags, null.ok = TRUE)) 76 | if ("c" %in% tags) { 77 | stop("'c' is a reserved tag in param6.") 78 | } 79 | } 80 | 81 | if (!is.null(value) && .check) { 82 | if (length(value) > 1) { 83 | assert_contains(support, as.Tuple(value)) 84 | } else { 85 | assert_contains(support, value) 86 | } 87 | } 88 | 89 | param <- list(id = id, support = str_support, value = value, tags = tags) 90 | class(param) <- "prm" 91 | param 92 | } 93 | 94 | #' @title Coercion Methods to prm 95 | #' @description Methods for coercing various objects to a [prm]. 96 | #' @param x (`ANY`) \cr Object to coerce. 97 | #' @param ... (`ANY`) \cr Other arguments, currently unused. 98 | #' @export 99 | as.prm <- function(x, ...) { # nolint 100 | UseMethod("as.prm") 101 | } 102 | 103 | #' @rdname as.prm 104 | #' @export 105 | as.prm.ParameterSet <- function(x, ...) { 106 | unname(Map(prm, 107 | id = x$ids, 108 | support = get_private(x)$.supports, 109 | value = expand_list(x$ids, x$values), 110 | tags = expand_list(x$ids, x$tags), 111 | .check = FALSE 112 | )) 113 | } 114 | 115 | #' @rdname as.prm 116 | #' @export 117 | as.prm.data.table <- function(x, ...) { # nolint 118 | checkmate::assertSubset(colnames(x), c("Id", "Support", "Value", "Tags")) 119 | unname(Map(prm, 120 | id = x$Id, 121 | support = x$Support, 122 | value = x$Value, 123 | tags = x$Tags 124 | )) 125 | } 126 | -------------------------------------------------------------------------------- /R/support_dictionary.R: -------------------------------------------------------------------------------- 1 | #' @name support_dictionary 2 | #' @title Support Dictionary 3 | #' @description [dictionar6::Dictionary] for parameter supports 4 | #' @details See [dictionar6::Dictionary] for full details of how to add other 5 | #' [set6::Set] objects as supports to this dictionary. 6 | #' @examples 7 | #' support_dictionary$keys 8 | #' support_dictionary$items 9 | #' @export 10 | NULL 11 | load_support <- function() { 12 | support_dictionary <- dct( 13 | universal = Universal$new(), 14 | logicals = Logicals$new(), 15 | naturals = Naturals$new(), 16 | posnaturals = PosNaturals$new(), 17 | integers = Integers$new(), 18 | posintegers = PosIntegers$new(), 19 | negintegers = NegIntegers$new(), 20 | posintegers0 = PosIntegers$new(zero = TRUE), 21 | negintegers0 = NegIntegers$new(zero = TRUE), 22 | rationals = Rationals$new(), 23 | posrationals = PosRationals$new(), 24 | negrationals = NegRationals$new(), 25 | posrationals0 = PosRationals$new(zero = TRUE), 26 | negrationals0 = NegRationals$new(zero = TRUE), 27 | reals = Reals$new(), 28 | posreals = PosReals$new(), 29 | negreals = NegReals$new(), 30 | posreals0 = PosReals$new(zero = TRUE), 31 | negreals0 = NegReals$new(zero = TRUE), 32 | extreals = ExtendedReals$new(), 33 | complex = Complex$new(), 34 | proportion = Interval$new(0, 1), 35 | nlogicals = Logicals$new()^"n", 36 | nnaturals = Naturals$new()^"n", 37 | nposnaturals = PosNaturals$new()^"n", 38 | nintegers = Integers$new()^"n", 39 | nposintegers = PosIntegers$new()^"n", 40 | nnegintegers = NegIntegers$new()^"n", 41 | nposintegers0 = PosIntegers$new(zero = TRUE)^"n", 42 | nnegintegers0 = NegIntegers$new(zero = TRUE)^"n", 43 | nrationals = Rationals$new()^"n", 44 | nposrationals = PosRationals$new()^"n", 45 | nnegrationals = NegRationals$new()^"n", 46 | nposrationals0 = PosRationals$new(zero = TRUE)^"n", 47 | nnegrationals0 = NegRationals$new(zero = TRUE)^"n", 48 | nreals = Reals$new()^"n", 49 | nposreals = PosReals$new()^"n", 50 | nnegreals = NegReals$new()^"n", 51 | nposreals0 = PosReals$new(zero = TRUE)^"n", 52 | nnegreals0 = NegReals$new(zero = TRUE)^"n", 53 | nextreals = ExtendedReals$new()^"n", 54 | ncomplex = Complex$new()^"n", 55 | nproportion = Interval$new(0, 1)^"n", 56 | types = "Set" 57 | ) 58 | } 59 | -------------------------------------------------------------------------------- /R/tools.R: -------------------------------------------------------------------------------- 1 | #' Check if two parameters are equal 2 | #' @description Primarily for internal use 3 | #' @param obj,expected [ParameterSet] 4 | #' @export 5 | expect_equal_ps <- function(obj, expected) { 6 | pobj <- get_private(obj) 7 | pexp <- get_private(expected) 8 | 9 | testthat::expect_setequal(pobj$.id, pexp$.id) 10 | 11 | testthat::expect_equal(sort_named_list(pobj$.value), 12 | sort_named_list(pexp$.value)) 13 | 14 | testthat::expect_equal(sort_named_list(pobj$.tags), 15 | sort_named_list(pexp$.tags)) 16 | 17 | testthat::expect_equal(sort_named_list(pobj$.supports), 18 | sort_named_list(pexp$.supports)) 19 | 20 | testthat::expect_equal(sort_named_list(pobj$.immutable), 21 | sort_named_list(pexp$.immutable)) 22 | 23 | if (is.null(pexp$.deps)) { 24 | testthat::expect_null(pobj$.deps) 25 | } else { 26 | testthat::expect_equal(pobj$.deps[order(pobj$.deps$id), ], 27 | pexp$.deps[order(pexp$.deps$id), ]) 28 | } 29 | 30 | if (is.null(pexp$.trafo)) { 31 | testthat::expect_null(pobj$.trafo) 32 | } else if (is.function(pexp$.trafo)) { 33 | testthat::expect_equal(deparse(pobj$.trafo), deparse(pexp$.trafo)) 34 | } else { 35 | testthat::expect_equal(deparse(sort_named_list(pobj$.trafo)), 36 | deparse(sort_named_list(pexp$.trafo))) 37 | } 38 | 39 | if (!is.null(pexp$.tag_properties)) { 40 | testthat::expect_setequal(names(pobj$.tag_properties), 41 | names(pexp$.tag_properties)) 42 | Map(testthat::expect_setequal, pobj$.tag_properties, pexp$.tag_properties) 43 | } 44 | 45 | 46 | testthat::expect_setequal(names(pobj$.isupports), names(pexp$.isupports)) 47 | Map(testthat::expect_setequal, pobj$.isupports, pexp$.isupports) 48 | 49 | invisible(NULL) 50 | } 51 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | #' @import set6 2 | #' @import R6 3 | #' @import dictionar6 4 | #' @importFrom data.table as.data.table data.table := 5 | #' @importFrom stats setNames 6 | "_PACKAGE" 7 | 8 | # nocov start 9 | utils::globalVariables(c("support_dictionary", "on", "id")) 10 | 11 | 12 | .onLoad = function(libname, pkgname) { # nolint 13 | assign("support_dictionary", load_support(), envir = topenv()) 14 | } 15 | # nocov end 16 | -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "param6" 3 | output: github_document 4 | --- 5 | 6 | ```{r setup, include=FALSE} 7 | knitr::opts_chunk$set(echo = TRUE) 8 | library(param6) 9 | set6::useUnicode(TRUE) 10 | ref <- function(val) sprintf("[%s](https://xoopr.github.io/param6/reference/%s.html)", 11 | as.character(substitute(val)), 12 | as.character(substitute(val))) 13 | cran <- function(val) sprintf("**[%s](https://CRAN.R-project.org/package=%s)**", 14 | as.character(substitute(val)), 15 | as.character(substitute(val))) 16 | gh <- function(org, repo) sprintf("**[%s](https://github.com/%s/%s)**", repo, org, repo) 17 | pkg <- function(pkg) sprintf("**%s**", as.character(substitute(pkg))) 18 | p6 <- "**param6**" 19 | ``` 20 | 21 | 22 | 23 | [![param6 status badge](https://raphaels1.r-universe.dev/badges/param6)](https://raphaels1.r-universe.dev) 24 | [![R-CMD-check / codecov](https://github.com/xoopR/param6/actions/workflows/check-covr.yml/badge.svg?branch=main)](https://github.com/xoopR/param6/actions/workflows/check-covr.yml) 25 | 26 | [![Repo Status](https://www.repostatus.org/badges/latest/active.svg)](https://github.com/xoopR/param6) 27 | [![Lifecycle](https://lifecycle.r-lib.org/articles/figures/lifecycle-experimental.svg)](https://github.com/xoopR/param6) 28 | 29 | [![CRAN Downloads](https://cranlogs.r-pkg.org/badges/grand-total/param6)](https://cran.r-project.org/package=param6) 30 | [![codecov](https://app.codecov.io/gh/xoopR/param6/branch/master/graph/badge.svg)](https://app.codecov.io/gh/xoopR/param6) 31 | [![dependencies](https://tinyverse.netlify.com/badge/param6)](https://CRAN.R-project.org/package=param6) 32 | [![License: MIT](https://img.shields.io/badge/License-MIT-yellow.svg)](https://opensource.org/licenses/MIT) 33 | 34 | ## What is param6? 35 | 36 | `r p6` is an R6 parameter set interface for storing multiple parameters that may be used in other R6 (or other paradigm) objects. Key use-cases for R6 parameter sets have been seen in packages such as: 37 | 38 | 1. `r cran(distr6)` - In which R6 distribution objects require parameter sets in order to parametrise a given probability distribution. Parameters as objects allows efficient getting and setting of parameters, as well as composition of distributions. 39 | 2. `r cran(mlr3)` - In which R6 learners require parameter sets for passing parameters to machine learning models. Storing parameter set objects allows efficient tuning over these parameters. 40 | 41 | ## Main Features 42 | 43 | Some main features/key use-cases of `r p6` includes: 44 | 45 | * Construction of parameter sets 46 | 47 | ```{r construction} 48 | prms <- list( 49 | prm(id = "a", support = "reals", value = 1), 50 | prm(id = "b", support = "naturals") 51 | ) 52 | ParameterSet$new(prms) 53 | ``` 54 | 55 | * Tagging parameters with properties 56 | 57 | ```{r tags} 58 | prms <- list( 59 | prm(id = "a", support = "reals", value = 1, tags = "t1"), 60 | prm(id = "b", support = "nnaturals", tags = "t2") 61 | ) 62 | ParameterSet$new(prms, 63 | list(required = "t1", unique = "t2")) 64 | ``` 65 | 66 | * Getting and setting parameter values 67 | 68 | ```{r values} 69 | prms <- list( 70 | prm(id = "a", support = "reals", value = 1, tags = "t1"), 71 | prm(id = "b", support = "naturals", tags = "t2") 72 | ) 73 | p <- ParameterSet$new(prms) 74 | p$values$b <- 2 75 | p$values 76 | p$get_values(tags = "t1", simplify = FALSE) 77 | ``` 78 | 79 | * Transform parameters 80 | 81 | ```{r trafo} 82 | p <- ParameterSet$new( 83 | list(prm(id = "a", support = "naturals", value = 4)) 84 | ) 85 | p$trafo <- function(x, self) { 86 | x$a <- 2^x$a 87 | x 88 | } 89 | p$get_values("a", simplify = FALSE) 90 | ``` 91 | 92 | * Parameter dependencies 93 | 94 | ```{r deps, error=TRUE} 95 | p <- ParameterSet$new(list( 96 | prm(id = "a", support = "naturals"), 97 | prm(id = "b", support = "naturals") 98 | )) 99 | p$add_dep("a", "b", cnd("eq", 4)) 100 | p$values$b <- 5 101 | p$values$a <- 1 # fails as b != 4 102 | p$values$b <- 4 103 | p$values$a <- 1 # now works 104 | p$get_values() 105 | ``` 106 | 107 | ## Why param6? 108 | 109 | `r p6` began as the `ParameterSet` object in `r cran(distr6)`. However this initial attempt at an R6 parameter set interface, had massive bottlenecks that were causing substantial problems in dependencies. `r p6` is an abstracted parameter set interface that draws influence from this initial design. `r p6` achieves faster run-times and smaller object-sizes than other parameter set packages by making the following design decisions: 110 | 111 | * `data.table` objects are minimised and only used when absolutely necessary, instead `list` objects are utilised. 112 | * Symbolic representation of sets is utilised via the `r cran(set6)` package in order to store sets as characters, thereby reducing object sizes. Additionally, `r p6` includes a `r ref(support_dictionary)` which stores constructed sets that can then be accessed via a string representation, thereby preventing the same set needing to be constructed multiple times. 113 | * `r cran(Rcpp)` is utilised via `r cran(set6)` in order to allow very fast containedness checks when checking values lie within a parameter support. 114 | * S3 is embraced for simple objects, such as the `r ref(prm)` object in order to increase speed in construction times. 115 | * Parameters are grouped internally by their supports, and not individually, allowing for a further increase in efficiency of both storage and runtimes in containedness checks 116 | * The notion of 'parameter set collections' is removed in favour of automated methods for setting and getting prefixes in parameter IDs 117 | 118 | ## Installation 119 | 120 | For the latest release on [CRAN](https://CRAN.R-project.org/package=param6), install with 121 | ```{r eval=FALSE} 122 | install.packages("param6") 123 | ``` 124 | 125 | Otherwise for the latest stable build 126 | ```{r eval=FALSE} 127 | remotes::install_github("xoopR/param6") 128 | ``` 129 | 130 | ## Future Plans 131 | 132 | The `r p6` API is still experimental and may be subject to major changes. 133 | To understand if `r p6` fulfills it's initial use-case correctly, the next step will be to incorporate the package in `r cran(distr6)`, which may involve minor or major changes to the current API. From there, Rcpp will be embraced more fully in `r cran(set6)` and then in `r p6` to improve package speed. 134 | 135 | ## Package Development and Contributing 136 | 137 | `r p6` is released under the [MIT licence](https://opensource.org/licenses/MIT). We welcome and appreciate all [new issues](https://github.com/xoopR/param6/issues) relating to bug reports, questions and suggestions. You can also [start a discussion](https://github.com/xoopR/param6/discussions) for more extensive feedback or feature suggestion. 138 | 139 | ## Acknowledgements 140 | 141 | As well as building on the work of `r cran(distr6)`, the designs and some method names of `r p6` are based on the work of `r cran(paradox)`. Additionally, some decisions were based on designs in `r gh("mrc-ide", "mcstate")`. 142 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | param6 2 | ================ 3 | 4 | 5 | 6 | [![param6 status badge](https://raphaels1.r-universe.dev/badges/param6)](https://raphaels1.r-universe.dev) 7 | [![R-CMD-check / 8 | codecov](https://github.com/xoopR/param6/actions/workflows/check-covr.yml/badge.svg?branch=main)](https://github.com/xoopR/param6/actions/workflows/check-covr.yml) 9 | 10 | [![Repo 11 | Status](https://www.repostatus.org/badges/latest/active.svg)](https://github.com/xoopR/param6) 12 | [![Lifecycle](https://lifecycle.r-lib.org/articles/figures/lifecycle-experimental.svg)](https://github.com/xoopR/param6) 13 | 14 | [![codecov](https://app.codecov.io/gh/xoopR/param6/branch/master/graph/badge.svg)](https://app.codecov.io/gh/xoopR/param6) 15 | [![dependencies](https://tinyverse.netlify.com/badge/param6)](https://CRAN.R-project.org/package=param6) 16 | [![License: 17 | MIT](https://img.shields.io/badge/License-MIT-yellow.svg)](https://opensource.org/licenses/MIT) 18 | 19 | ## What is param6? 20 | 21 | **param6** is an R6 parameter set interface for storing multiple 22 | parameters that may be used in other R6 (or other paradigm) objects. Key 23 | use-cases for R6 parameter sets have been seen in packages such as: 24 | 25 | 1. **[distr6](https://CRAN.R-project.org/package=distr6)** - In which 26 | R6 distribution objects require parameter sets in order to 27 | parametrise a given probability distribution. Parameters as objects 28 | allows efficient getting and setting of parameters, as well as 29 | composition of distributions. 30 | 2. **[mlr3](https://CRAN.R-project.org/package=mlr3)** - In which R6 31 | learners require parameter sets for passing parameters to machine 32 | learning models. Storing parameter set objects allows efficient 33 | tuning over these parameters. 34 | 35 | ## Main Features 36 | 37 | Some main features/key use-cases of **param6** includes: 38 | 39 | - Construction of parameter sets 40 | 41 | ``` r 42 | prms <- list( 43 | prm(id = "a", support = "reals", value = 1), 44 | prm(id = "b", support = "naturals") 45 | ) 46 | ParameterSet$new(prms) 47 | ``` 48 | 49 | ## Id Support Value Tags 50 | ## 1: a ℝ 1 51 | ## 2: b ℕ0 52 | 53 | - Tagging parameters with properties 54 | 55 | ``` r 56 | prms <- list( 57 | prm(id = "a", support = "reals", value = 1, tags = "t1"), 58 | prm(id = "b", support = "nnaturals", tags = "t2") 59 | ) 60 | ParameterSet$new(prms, 61 | list(required = "t1", unique = "t2")) 62 | ``` 63 | 64 | ## Id Support Value Tags 65 | ## 1: a ℝ 1 t1 66 | ## 2: b ℕ0^n t2 67 | 68 | - Getting and setting parameter values 69 | 70 | ``` r 71 | prms <- list( 72 | prm(id = "a", support = "reals", value = 1, tags = "t1"), 73 | prm(id = "b", support = "naturals", tags = "t2") 74 | ) 75 | p <- ParameterSet$new(prms) 76 | p$values$b <- 2 77 | p$values 78 | ``` 79 | 80 | ## $a 81 | ## [1] 1 82 | ## 83 | ## $b 84 | ## [1] 2 85 | 86 | ``` r 87 | p$get_values(tags = "t1", simplify = FALSE) 88 | ``` 89 | 90 | ## $a 91 | ## [1] 1 92 | 93 | - Transform parameters 94 | 95 | ``` r 96 | p <- ParameterSet$new( 97 | list(prm(id = "a", support = "naturals", value = 4)) 98 | ) 99 | p$trafo <- function(x, self) { 100 | x$a <- 2^x$a 101 | x 102 | } 103 | p$get_values("a", simplify = FALSE) 104 | ``` 105 | 106 | ## $a 107 | ## [1] 16 108 | 109 | - Parameter dependencies 110 | 111 | ``` r 112 | p <- ParameterSet$new(list( 113 | prm(id = "a", support = "naturals"), 114 | prm(id = "b", support = "naturals") 115 | )) 116 | p$add_dep("a", "b", cnd("eq", 4)) 117 | p$values$b <- 5 118 | p$values$a <- 1 # fails as b != 4 119 | ``` 120 | 121 | ## Error in .return_fail(msg = msg, error_on_fail): Dependency of a on 'b == {4}' failed. 122 | 123 | ``` r 124 | p$values$b <- 4 125 | p$values$a <- 1 # now works 126 | p$get_values() 127 | ``` 128 | 129 | ## $a 130 | ## [1] 1 131 | ## 132 | ## $b 133 | ## [1] 4 134 | 135 | ## Why param6? 136 | 137 | **param6** began as the `ParameterSet` object in 138 | **[distr6](https://CRAN.R-project.org/package=distr6)**. However this 139 | initial attempt at an R6 parameter set interface, had massive 140 | bottlenecks that were causing substantial problems in dependencies. 141 | **param6** is an abstracted parameter set interface that draws influence 142 | from this initial design. **param6** achieves faster run-times and 143 | smaller object-sizes than other parameter set packages by making the 144 | following design decisions: 145 | 146 | - `data.table` objects are minimised and only used when absolutely 147 | necessary, instead `list` objects are utilised. 148 | - Symbolic representation of sets is utilised via the 149 | **[set6](https://CRAN.R-project.org/package=set6)** package in order 150 | to store sets as characters, thereby reducing object sizes. 151 | Additionally, **param6** includes a 152 | [support\_dictionary](https://xoopr.github.io/param6/reference/support_dictionary.html) 153 | which stores constructed sets that can then be accessed via a string 154 | representation, thereby preventing the same set needing to be 155 | constructed multiple times. 156 | - **[Rcpp](https://CRAN.R-project.org/package=Rcpp)** is utilised via 157 | **[set6](https://CRAN.R-project.org/package=set6)** in order to 158 | allow very fast containedness checks when checking values lie within 159 | a parameter support. 160 | - S3 is embraced for simple objects, such as the 161 | [prm](https://xoopr.github.io/param6/reference/prm.html) object in 162 | order to increase speed in construction times. 163 | - Parameters are grouped internally by their supports, and not 164 | individually, allowing for a further increase in efficiency of both 165 | storage and runtimes in containedness checks 166 | - The notion of ‘parameter set collections’ is removed in favour of 167 | automated methods for setting and getting prefixes in parameter IDs 168 | 169 | 170 | ## Installation 171 | 172 | param6 can be installed from 173 | [R-Universe](https://raphaels1.r-universe.dev/ui#package:param6) 174 | 175 | ``` r 176 | # Enable repository from raphaels1 177 | options(repos = c( 178 | raphaels1 = 'https://raphaels1.r-universe.dev', 179 | CRAN = 'https://cloud.r-project.org')) 180 | # Download and install param6 in R 181 | install.packages('param6') 182 | ``` 183 | 184 | And GitHub 185 | 186 | ``` r 187 | remotes::install_github("xoopR/param6") 188 | ``` 189 | 190 | param6 [will not be on 191 | CRAN](https://twitter.com/RaphaelS101/status/1506321623250571265) for 192 | the forseeable future. 193 | 194 | ## Future Plans 195 | 196 | The **param6** API is still experimental and may be subject to major 197 | changes. To understand if **param6** fulfills it’s initial use-case 198 | correctly, the next step will be to incorporate the package in 199 | **[distr6](https://CRAN.R-project.org/package=distr6)**, which may 200 | involve minor or major changes to the current API. From there, Rcpp will 201 | be embraced more fully in 202 | **[set6](https://CRAN.R-project.org/package=set6)** and then in 203 | **param6** to improve package speed. 204 | 205 | ## Package Development and Contributing 206 | 207 | **param6** is released under the [MIT 208 | licence](https://opensource.org/licenses/MIT). We welcome and appreciate 209 | all [new issues](https://github.com/xoopR/param6/issues) relating to bug 210 | reports, questions and suggestions. You can also [start a 211 | discussion](https://github.com/xoopR/param6/discussions) for more 212 | extensive feedback or feature suggestion. 213 | 214 | ## Acknowledgements 215 | 216 | As well as building on the work of 217 | **[distr6](https://CRAN.R-project.org/package=distr6)**, the designs and 218 | some method names of **param6** are based on the work of 219 | **[paradox](https://CRAN.R-project.org/package=paradox)**. Additionally, 220 | some decisions were based on designs in 221 | **[mcstate](https://github.com/mrc-ide/mcstate)**. 222 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | ## Reason for early submission 2 | 3 | * Patched bugs previously not covered 4 | 5 | ## Test Results 6 | 7 | No NOTEs, WARNINGs, or ERRORs. 8 | 9 | ## Test environments 10 | 11 | * Microsoft Windows Server 2019, R Release 12 | * Mac OS X, R Release 13 | * Ubuntu, R Release 14 | * Ubuntu, R Devel 15 | * Ubuntu, R Oldrel 16 | 17 | ## Reverse Dependencies 18 | 19 | All reverse dependencies OK. 20 | -------------------------------------------------------------------------------- /man-roxygen/param_prms.R: -------------------------------------------------------------------------------- 1 | #' @param prms (`list()`) \cr List of [prm] objects. Ids should be unique. 2 | -------------------------------------------------------------------------------- /man-roxygen/param_sort.R: -------------------------------------------------------------------------------- 1 | #' @param sort (`logical(1)`) \cr If `TRUE` (default) sorts the `ParameterSet` 2 | #' alphabetically by id. 3 | -------------------------------------------------------------------------------- /man-roxygen/param_tag_properties.R: -------------------------------------------------------------------------------- 1 | #' @param tag_properties (`list()`) \cr 2 | #' List of tag properties. Currently supported properties are: i) 'required' - 3 | #' parameters with this tag property must be non-NULL; ii) 'linked' - only one 4 | #' parameter in a linked tag group can be non-NULL and the others should be 5 | #' NULL, this only makes sense with an associated `trafo`; iii) 'unique' - 6 | #' parameters with this tag must have no duplicated elements, only makes sense 7 | #' for vector parameters; iv) 'immutable' - parameters with this tag cannot be 8 | #' updated after construction. 9 | -------------------------------------------------------------------------------- /man/ParameterSet.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ParameterSet.R 3 | \name{ParameterSet} 4 | \alias{ParameterSet} 5 | \title{Parameter Set} 6 | \description{ 7 | \code{ParameterSet} objects store parameters (\link{prm} objects) and add 8 | internal validation checks and methods for: 9 | \itemize{ 10 | \item Getting and setting parameter values 11 | \item Transforming parameter values 12 | \item Providing dependencies of parameters on each other 13 | \item Tagging parameters, which may enable further properties 14 | \item Storing subsets of parameters under prefixes 15 | } 16 | } 17 | \examples{ 18 | library(set6) 19 | 20 | ## $value examples 21 | p <- ParameterSet$new(list(prm(id = "a", support = Reals$new()))) 22 | p$values$a <- 2 23 | p$values 24 | 25 | ## $trafo examples 26 | p <- ParameterSet$new(list(prm(id = "a", 2, support = Reals$new()))) 27 | p$trafo 28 | 29 | # simple transformation 30 | p$get_values() 31 | p$trafo <- function(x, self) { 32 | x$a <- exp(x$a) 33 | x 34 | } 35 | p$get_values() 36 | 37 | # more complex transformation on tags 38 | p <- ParameterSet$new( 39 | list(prm(id = "a", 2, support = Reals$new(), tags = "t1"), 40 | prm(id = "b", 3, support = Reals$new(), tags = "t1"), 41 | prm(id = "d", 4, support = Reals$new())) 42 | ) 43 | # make sure `transform = FALSE` to prevent infinite recursion 44 | p$trafo <- function(x, self) { 45 | out <- lapply(self$get_values(tags = "t1", transform = FALSE), 46 | function(.x) 2^.x) 47 | out <- c(out, list(d = x$d)) 48 | out 49 | } 50 | p$get_values() 51 | 52 | 53 | ## ------------------------------------------------ 54 | ## Method `ParameterSet$new` 55 | ## ------------------------------------------------ 56 | 57 | prms <- list( 58 | prm("a", Set$new(1), 1, tags = "t1"), 59 | prm("b", "reals", 1.5, tags = "t1"), 60 | prm("d", "reals", 2, tags = "t2") 61 | ) 62 | ParameterSet$new(prms) 63 | 64 | ## ------------------------------------------------ 65 | ## Method `ParameterSet$print` 66 | ## ------------------------------------------------ 67 | 68 | prms <- list( 69 | prm("a", Set$new(1), 1, tags = "t1"), 70 | prm("b", "reals", 1.5, tags = "t1"), 71 | prm("d", "reals", 2, tags = "t2") 72 | ) 73 | p <- ParameterSet$new(prms) 74 | p$print() 75 | print(p) 76 | p 77 | 78 | ## ------------------------------------------------ 79 | ## Method `ParameterSet$get_values` 80 | ## ------------------------------------------------ 81 | 82 | prms <- list( 83 | prm("a", "reals", 1, tags = "t1"), 84 | prm("b", "reals", 1.5, tags = "t1"), 85 | prm("d", "reals", tags = "t2") 86 | ) 87 | p <- ParameterSet$new(prms) 88 | p$trafo <- function(x, self) { 89 | x$a <- exp(x$a) 90 | x 91 | } 92 | p$get_values() 93 | p$get_values(inc_null = FALSE) 94 | p$get_values(id = "a") 95 | p$get_values(tags = "t1") 96 | 97 | ## ------------------------------------------------ 98 | ## Method `ParameterSet$add_dep` 99 | ## ------------------------------------------------ 100 | 101 | # not run as errors 102 | \dontrun{ 103 | # Dependency on specific value 104 | prms <- list( 105 | prm("a", "reals", NULL), 106 | prm("b", "reals", 1) 107 | ) 108 | p <- ParameterSet$new(prms) 109 | p$add_dep("a", "b", cnd("eq", 2)) 110 | # 'a' can only be set if 'b' equals 2 111 | p$values$a <- 1 112 | p$values <- list(a = 1, b = 2) 113 | 114 | # Dependency on variable value 115 | prms <- list( 116 | prm("a", "reals", NULL), 117 | prm("b", "reals", 1) 118 | ) 119 | p <- ParameterSet$new(prms) 120 | p$add_dep("a", "b", cnd("eq", id = "b")) 121 | # 'a' can only be set if it equals 'b' 122 | p$values$a <- 2 123 | p$values <- list(a = 2, b = 2) 124 | } 125 | 126 | ## ------------------------------------------------ 127 | ## Method `ParameterSet$extract` 128 | ## ------------------------------------------------ 129 | 130 | # extract by id 131 | prms <- list( 132 | prm("a", "reals", NULL), 133 | prm("b", "reals", 1) 134 | ) 135 | p <- ParameterSet$new(prms) 136 | p$extract("a") 137 | # equivalently 138 | p["a"] 139 | 140 | # extract by prefix 141 | prms <- list( 142 | prm("Pre1__par1", Set$new(1), 1, tags = "t1"), 143 | prm("Pre1__par2", "reals", 3, tags = "t2"), 144 | prm("Pre2__par1", Set$new(1), 1, tags = "t1"), 145 | prm("Pre2__par2", "reals", 3, tags = "t2") 146 | ) 147 | p <- ParameterSet$new(prms) 148 | p$extract(tags = "t1") 149 | p$extract(prefix = "Pre1") 150 | # equivalently 151 | p[prefix = "Pre1"] 152 | } 153 | \section{Active bindings}{ 154 | \if{html}{\out{
}} 155 | \describe{ 156 | \item{\code{tags}}{None -> \code{named_list()} \cr 157 | Get tags from the parameter set.} 158 | 159 | \item{\code{ids}}{None -> \code{character()} \cr 160 | Get ids from the parameter set.} 161 | 162 | \item{\code{length}}{None -> \code{integer(1)} \cr 163 | Get the length of the parameter set as the number of parameters.} 164 | 165 | \item{\code{deps}}{None -> \link[data.table:data.table]{data.table::data.table} 166 | Get parameter dependencies, NULL if none.} 167 | 168 | \item{\code{supports}}{None -> \code{named_list()} \cr 169 | Get supports from the parameter set.} 170 | 171 | \item{\code{tag_properties}}{\code{list() -> self} / None -> \code{list()} \cr 172 | If \code{x} is missing then returns tag properties if any. \cr 173 | If \code{x} is not missing then used to tag properties. Currently properties 174 | can either be: \cr 175 | i) 'required' - parameters with this tag must have set (non-NULL) 176 | values; if a parameter is both 'required' and 'linked' then exactly 177 | one parameter in the 'linked' tag must be tagged;\cr 178 | ii) 'linked' - parameters with 'linked' tags are dependent on one another 179 | and only one can be set (non-NULL at a time);\cr 180 | iii) 'unique' - parameters with this tag must have no duplicated 181 | elements, therefore this tag only makes sense for vector parameters;\cr 182 | iv) 'immutable' - parameters with this tag cannot be updated after 183 | construction.} 184 | 185 | \item{\code{values}}{\code{list() -> self} / None -> \code{list()} \cr 186 | If \code{x} is missing then returns the set (non-NULL) values without 187 | transformation or filtering; use \verb{$get_values} for a more sophisticated 188 | getter of values. \cr 189 | If \code{x} is not missing then used to set values of parameters, which are 190 | first checked internally with the \verb{$check} method before setting the new 191 | values. \cr 192 | See examples at end.} 193 | 194 | \item{\code{trafo}}{\verb{function()|list() -> self} / None -> \verb{function()|list()} 195 | \cr 196 | If \code{x} is missing then returns a transformation function if previously 197 | set, a list of transformation functions, otherwise \code{NULL}. \cr 198 | If \code{x} is not missing then it should either be: 199 | \itemize{ 200 | \item a function with arguments \code{x} and \code{self}, which internally correspond 201 | to \code{self} being the \code{ParameterSet} the transformation is being added to, 202 | and \code{x <- self$values}. 203 | \item a list of functions like above 204 | } 205 | 206 | The transformation function is automatically called after a call to 207 | \code{self$get_values()} and is used to transform set values, it should 208 | therefore result in a list. If using \code{self$get_values()} within the 209 | transformation function, make sure to set \code{transform = FALSE} to prevent 210 | infinite recursion, see examples at end. 211 | 212 | It is generally safer to call the transformation with 213 | \verb{$transform(self$values)} as this will first check to see if \verb{$trafo} 214 | is a function or list. If the latter then each function in the list is 215 | applied, one after the other.} 216 | } 217 | \if{html}{\out{
}} 218 | } 219 | \section{Methods}{ 220 | \subsection{Public methods}{ 221 | \itemize{ 222 | \item \href{#method-new}{\code{ParameterSet$new()}} 223 | \item \href{#method-print}{\code{ParameterSet$print()}} 224 | \item \href{#method-get_values}{\code{ParameterSet$get_values()}} 225 | \item \href{#method-add_dep}{\code{ParameterSet$add_dep()}} 226 | \item \href{#method-rep}{\code{ParameterSet$rep()}} 227 | \item \href{#method-extract}{\code{ParameterSet$extract()}} 228 | \item \href{#method-remove}{\code{ParameterSet$remove()}} 229 | \item \href{#method-getParameterValue}{\code{ParameterSet$getParameterValue()}} 230 | \item \href{#method-setParameterValue}{\code{ParameterSet$setParameterValue()}} 231 | \item \href{#method-set_values}{\code{ParameterSet$set_values()}} 232 | \item \href{#method-parameters}{\code{ParameterSet$parameters()}} 233 | \item \href{#method-transform}{\code{ParameterSet$transform()}} 234 | \item \href{#method-clone}{\code{ParameterSet$clone()}} 235 | } 236 | } 237 | \if{html}{\out{
}} 238 | \if{html}{\out{}} 239 | \if{latex}{\out{\hypertarget{method-new}{}}} 240 | \subsection{Method \code{new()}}{ 241 | Constructs a \code{ParameterSet} object. 242 | \subsection{Usage}{ 243 | \if{html}{\out{
}}\preformatted{ParameterSet$new(prms = list(), tag_properties = NULL)}\if{html}{\out{
}} 244 | } 245 | 246 | \subsection{Arguments}{ 247 | \if{html}{\out{
}} 248 | \describe{ 249 | \item{\code{prms}}{(\code{list()}) \cr List of \link{prm} objects. Ids should be unique.} 250 | 251 | \item{\code{tag_properties}}{(\code{list()}) \cr 252 | List of tag properties. Currently supported properties are: i) 'required' - 253 | parameters with this tag property must be non-NULL; ii) 'linked' - only one 254 | parameter in a linked tag group can be non-NULL and the others should be 255 | NULL, this only makes sense with an associated \code{trafo}; iii) 'unique' - 256 | parameters with this tag must have no duplicated elements, only makes sense 257 | for vector parameters; iv) 'immutable' - parameters with this tag cannot be 258 | updated after construction.} 259 | } 260 | \if{html}{\out{
}} 261 | } 262 | \subsection{Examples}{ 263 | \if{html}{\out{
}} 264 | \preformatted{prms <- list( 265 | prm("a", Set$new(1), 1, tags = "t1"), 266 | prm("b", "reals", 1.5, tags = "t1"), 267 | prm("d", "reals", 2, tags = "t2") 268 | ) 269 | ParameterSet$new(prms) 270 | } 271 | \if{html}{\out{
}} 272 | 273 | } 274 | 275 | } 276 | \if{html}{\out{
}} 277 | \if{html}{\out{}} 278 | \if{latex}{\out{\hypertarget{method-print}{}}} 279 | \subsection{Method \code{print()}}{ 280 | Prints the \code{ParameterSet} after coercion with 281 | \link{as.data.table.ParameterSet}. 282 | \subsection{Usage}{ 283 | \if{html}{\out{
}}\preformatted{ParameterSet$print(sort = TRUE)}\if{html}{\out{
}} 284 | } 285 | 286 | \subsection{Arguments}{ 287 | \if{html}{\out{
}} 288 | \describe{ 289 | \item{\code{sort}}{(\code{logical(1)}) \cr If \code{TRUE} (default) sorts the \code{ParameterSet} 290 | alphabetically by id.} 291 | } 292 | \if{html}{\out{
}} 293 | } 294 | \subsection{Examples}{ 295 | \if{html}{\out{
}} 296 | \preformatted{prms <- list( 297 | prm("a", Set$new(1), 1, tags = "t1"), 298 | prm("b", "reals", 1.5, tags = "t1"), 299 | prm("d", "reals", 2, tags = "t2") 300 | ) 301 | p <- ParameterSet$new(prms) 302 | p$print() 303 | print(p) 304 | p 305 | } 306 | \if{html}{\out{
}} 307 | 308 | } 309 | 310 | } 311 | \if{html}{\out{
}} 312 | \if{html}{\out{}} 313 | \if{latex}{\out{\hypertarget{method-get_values}{}}} 314 | \subsection{Method \code{get_values()}}{ 315 | Gets values from the \code{ParameterSet} with options to filter 316 | by specific IDs and tags, and also to transform the values. 317 | \subsection{Usage}{ 318 | \if{html}{\out{
}}\preformatted{ParameterSet$get_values( 319 | id = NULL, 320 | tags = NULL, 321 | transform = TRUE, 322 | inc_null = TRUE, 323 | simplify = TRUE 324 | )}\if{html}{\out{
}} 325 | } 326 | 327 | \subsection{Arguments}{ 328 | \if{html}{\out{
}} 329 | \describe{ 330 | \item{\code{id}}{(\code{character()}) \cr 331 | If not NULL then returns values for given \code{ids}.} 332 | 333 | \item{\code{tags}}{(\code{character()}) \cr 334 | If not NULL then returns values for given \code{tags}.} 335 | 336 | \item{\code{transform}}{(\code{logical(1)}) \cr 337 | If \code{TRUE} (default) and \verb{$trafo} is not \code{NULL} then runs the set 338 | transformation function before returning the values.} 339 | 340 | \item{\code{inc_null}}{(\code{logical(1)}) \cr 341 | If \code{TRUE} (default) then returns values for all ids even if \code{NULL}.} 342 | 343 | \item{\code{simplify}}{(\code{logical(1)}) \cr 344 | If \code{TRUE} (default) then unlists scalar values, otherwise always 345 | returns a list.} 346 | } 347 | \if{html}{\out{
}} 348 | } 349 | \subsection{Examples}{ 350 | \if{html}{\out{
}} 351 | \preformatted{prms <- list( 352 | prm("a", "reals", 1, tags = "t1"), 353 | prm("b", "reals", 1.5, tags = "t1"), 354 | prm("d", "reals", tags = "t2") 355 | ) 356 | p <- ParameterSet$new(prms) 357 | p$trafo <- function(x, self) { 358 | x$a <- exp(x$a) 359 | x 360 | } 361 | p$get_values() 362 | p$get_values(inc_null = FALSE) 363 | p$get_values(id = "a") 364 | p$get_values(tags = "t1") 365 | } 366 | \if{html}{\out{
}} 367 | 368 | } 369 | 370 | } 371 | \if{html}{\out{
}} 372 | \if{html}{\out{}} 373 | \if{latex}{\out{\hypertarget{method-add_dep}{}}} 374 | \subsection{Method \code{add_dep()}}{ 375 | Gets values from the \code{ParameterSet} with options to filter 376 | by specific IDs and tags, and also to transform the values. 377 | \subsection{Usage}{ 378 | \if{html}{\out{
}}\preformatted{ParameterSet$add_dep(id, on, cnd)}\if{html}{\out{
}} 379 | } 380 | 381 | \subsection{Arguments}{ 382 | \if{html}{\out{
}} 383 | \describe{ 384 | \item{\code{id}}{(\code{character(1)}) \cr 385 | The dependent variable for the condition that depends on the given 386 | variable, \code{on}, being a particular value. Should be in \code{self$ids}.} 387 | 388 | \item{\code{on}}{(\code{character(1)}) \cr 389 | The independent variable for the condition that is depended on by the 390 | given variable, \code{id}. Should be in \code{self$ids}.} 391 | 392 | \item{\code{cnd}}{(\code{cnd(1)}) \cr 393 | The condition defined by \link{cnd} which determines how \code{id} depends on \code{on}.} 394 | } 395 | \if{html}{\out{
}} 396 | } 397 | \subsection{Examples}{ 398 | \if{html}{\out{
}} 399 | \preformatted{# not run as errors 400 | \dontrun{ 401 | # Dependency on specific value 402 | prms <- list( 403 | prm("a", "reals", NULL), 404 | prm("b", "reals", 1) 405 | ) 406 | p <- ParameterSet$new(prms) 407 | p$add_dep("a", "b", cnd("eq", 2)) 408 | # 'a' can only be set if 'b' equals 2 409 | p$values$a <- 1 410 | p$values <- list(a = 1, b = 2) 411 | 412 | # Dependency on variable value 413 | prms <- list( 414 | prm("a", "reals", NULL), 415 | prm("b", "reals", 1) 416 | ) 417 | p <- ParameterSet$new(prms) 418 | p$add_dep("a", "b", cnd("eq", id = "b")) 419 | # 'a' can only be set if it equals 'b' 420 | p$values$a <- 2 421 | p$values <- list(a = 2, b = 2) 422 | } 423 | } 424 | \if{html}{\out{
}} 425 | 426 | } 427 | 428 | } 429 | \if{html}{\out{
}} 430 | \if{html}{\out{}} 431 | \if{latex}{\out{\hypertarget{method-rep}{}}} 432 | \subsection{Method \code{rep()}}{ 433 | Replicate the \code{ParameterSet} with identical parameters. 434 | In order to avoid duplicated parameter ids, every id in the 435 | \code{ParameterSet} is given a \code{prefix} in the format \code{prefix__id}. In 436 | addition, linked tags are also given the same prefix to prevent 437 | incorrectly linking parameters. 438 | 439 | The primary use-case of this method is to treat the \code{ParameterSet} as a 440 | collection of identical \code{ParameterSet} objects. 441 | 442 | Note that this mutates the \code{ParameterSet}, if you want to instead create 443 | a new object then use \link{rep.ParameterSet} instead (or copy and deep clone) 444 | first. 445 | \subsection{Usage}{ 446 | \if{html}{\out{
}}\preformatted{ParameterSet$rep(times, prefix)}\if{html}{\out{
}} 447 | } 448 | 449 | \subsection{Arguments}{ 450 | \if{html}{\out{
}} 451 | \describe{ 452 | \item{\code{times}}{(\code{integer(1)}) \cr 453 | Numer of times to replicate the \code{ParameterSet}.} 454 | 455 | \item{\code{prefix}}{(\code{character(1)|character(length(times))}) \cr 456 | The prefix to add to ids and linked tags. If length \code{1} then is 457 | internally coerced to \code{paste0(prefix, seq(times))}, otherwise the length 458 | should be equal to \code{times}.} 459 | } 460 | \if{html}{\out{
}} 461 | } 462 | } 463 | \if{html}{\out{
}} 464 | \if{html}{\out{}} 465 | \if{latex}{\out{\hypertarget{method-extract}{}}} 466 | \subsection{Method \code{extract()}}{ 467 | Creates a new \code{ParameterSet} by extracting the given 468 | parameters. 469 | \subsection{Usage}{ 470 | \if{html}{\out{
}}\preformatted{ParameterSet$extract(id = NULL, tags = NULL, prefix = NULL)}\if{html}{\out{
}} 471 | } 472 | 473 | \subsection{Arguments}{ 474 | \if{html}{\out{
}} 475 | \describe{ 476 | \item{\code{id}}{(\code{character()}) \cr 477 | If not \code{NULL} then specifies the parameters by id to extract. Should be 478 | \code{NULL} if \code{prefix} is not \code{NULL}.} 479 | 480 | \item{\code{tags}}{(\code{character()}) \cr 481 | If not \code{NULL} then specifies the parameters by tag to extract. Should be 482 | \code{NULL} if \code{prefix} is not \code{NULL}.} 483 | 484 | \item{\code{prefix}}{(\code{character()}) \cr 485 | If not \code{NULL} then extracts parameters according to their prefix and 486 | additionally removes the prefix from the id. A prefix is determined as 487 | the string before \code{"__"} in an id.} 488 | } 489 | \if{html}{\out{
}} 490 | } 491 | \subsection{Examples}{ 492 | \if{html}{\out{
}} 493 | \preformatted{# extract by id 494 | prms <- list( 495 | prm("a", "reals", NULL), 496 | prm("b", "reals", 1) 497 | ) 498 | p <- ParameterSet$new(prms) 499 | p$extract("a") 500 | # equivalently 501 | p["a"] 502 | 503 | # extract by prefix 504 | prms <- list( 505 | prm("Pre1__par1", Set$new(1), 1, tags = "t1"), 506 | prm("Pre1__par2", "reals", 3, tags = "t2"), 507 | prm("Pre2__par1", Set$new(1), 1, tags = "t1"), 508 | prm("Pre2__par2", "reals", 3, tags = "t2") 509 | ) 510 | p <- ParameterSet$new(prms) 511 | p$extract(tags = "t1") 512 | p$extract(prefix = "Pre1") 513 | # equivalently 514 | p[prefix = "Pre1"] 515 | } 516 | \if{html}{\out{
}} 517 | 518 | } 519 | 520 | } 521 | \if{html}{\out{
}} 522 | \if{html}{\out{}} 523 | \if{latex}{\out{\hypertarget{method-remove}{}}} 524 | \subsection{Method \code{remove()}}{ 525 | Removes the given parameters from the set. 526 | \subsection{Usage}{ 527 | \if{html}{\out{
}}\preformatted{ParameterSet$remove(id = NULL, prefix = NULL)}\if{html}{\out{
}} 528 | } 529 | 530 | \subsection{Arguments}{ 531 | \if{html}{\out{
}} 532 | \describe{ 533 | \item{\code{id}}{(\code{character()}) \cr 534 | If not \code{NULL} then specifies the parameters by id to extract. Should be 535 | \code{NULL} if \code{prefix} is not \code{NULL}.} 536 | 537 | \item{\code{prefix}}{(\code{character()}) \cr 538 | If not \code{NULL} then extracts parameters according to their prefix and 539 | additionally removes the prefix from the id. A prefix is determined as 540 | the string before \code{"__"} in an id.} 541 | } 542 | \if{html}{\out{
}} 543 | } 544 | } 545 | \if{html}{\out{
}} 546 | \if{html}{\out{}} 547 | \if{latex}{\out{\hypertarget{method-getParameterValue}{}}} 548 | \subsection{Method \code{getParameterValue()}}{ 549 | Deprecated method added for distr6 compatibility. 550 | Use $values/$get_values() in the future. 551 | Will be removed in 0.3.0. 552 | \subsection{Usage}{ 553 | \if{html}{\out{
}}\preformatted{ParameterSet$getParameterValue(id, ...)}\if{html}{\out{
}} 554 | } 555 | 556 | \subsection{Arguments}{ 557 | \if{html}{\out{
}} 558 | \describe{ 559 | \item{\code{id}}{Parameter id} 560 | 561 | \item{\code{...}}{Unused} 562 | } 563 | \if{html}{\out{
}} 564 | } 565 | } 566 | \if{html}{\out{
}} 567 | \if{html}{\out{}} 568 | \if{latex}{\out{\hypertarget{method-setParameterValue}{}}} 569 | \subsection{Method \code{setParameterValue()}}{ 570 | Deprecated method added for distr6 compatibility. 571 | Use $set_values in the future. 572 | Will be removed in 0.3.0. 573 | \subsection{Usage}{ 574 | \if{html}{\out{
}}\preformatted{ParameterSet$setParameterValue(..., lst = list(...))}\if{html}{\out{
}} 575 | } 576 | 577 | \subsection{Arguments}{ 578 | \if{html}{\out{
}} 579 | \describe{ 580 | \item{\code{...}}{Parameter ids} 581 | 582 | \item{\code{lst}}{List of parameter ids} 583 | } 584 | \if{html}{\out{
}} 585 | } 586 | } 587 | \if{html}{\out{
}} 588 | \if{html}{\out{}} 589 | \if{latex}{\out{\hypertarget{method-set_values}{}}} 590 | \subsection{Method \code{set_values()}}{ 591 | Convenience function for setting multiple parameters 592 | without changing or accidentally removing others. 593 | \subsection{Usage}{ 594 | \if{html}{\out{
}}\preformatted{ParameterSet$set_values(..., lst = list(...))}\if{html}{\out{
}} 595 | } 596 | 597 | \subsection{Arguments}{ 598 | \if{html}{\out{
}} 599 | \describe{ 600 | \item{\code{...}}{Parameter ids} 601 | 602 | \item{\code{lst}}{List of parameter ids} 603 | } 604 | \if{html}{\out{
}} 605 | } 606 | } 607 | \if{html}{\out{
}} 608 | \if{html}{\out{}} 609 | \if{latex}{\out{\hypertarget{method-parameters}{}}} 610 | \subsection{Method \code{parameters()}}{ 611 | Deprecated method added for distr6 compatibility. 612 | Use $print/as.data.table() in the future. 613 | Will be removed in 0.3.0. 614 | \subsection{Usage}{ 615 | \if{html}{\out{
}}\preformatted{ParameterSet$parameters(...)}\if{html}{\out{
}} 616 | } 617 | 618 | \subsection{Arguments}{ 619 | \if{html}{\out{
}} 620 | \describe{ 621 | \item{\code{...}}{Unused} 622 | } 623 | \if{html}{\out{
}} 624 | } 625 | } 626 | \if{html}{\out{
}} 627 | \if{html}{\out{}} 628 | \if{latex}{\out{\hypertarget{method-transform}{}}} 629 | \subsection{Method \code{transform()}}{ 630 | Applies the internal transformation function. 631 | If no function has been passed to \verb{$trafo} then \code{x} is returned 632 | unchanged. If \verb{$trafo} is a function then \code{x} is passed directly to 633 | this. If \verb{$trafo} is a list then \code{x} is evaluated and passed down the 634 | list iteratively. 635 | \subsection{Usage}{ 636 | \if{html}{\out{
}}\preformatted{ParameterSet$transform(x = self$values)}\if{html}{\out{
}} 637 | } 638 | 639 | \subsection{Arguments}{ 640 | \if{html}{\out{
}} 641 | \describe{ 642 | \item{\code{x}}{(\verb{named list(1)}) \cr 643 | List of values to transform.} 644 | } 645 | \if{html}{\out{
}} 646 | } 647 | \subsection{Returns}{ 648 | \verb{named list(1)} 649 | } 650 | } 651 | \if{html}{\out{
}} 652 | \if{html}{\out{}} 653 | \if{latex}{\out{\hypertarget{method-clone}{}}} 654 | \subsection{Method \code{clone()}}{ 655 | The objects of this class are cloneable with this method. 656 | \subsection{Usage}{ 657 | \if{html}{\out{
}}\preformatted{ParameterSet$clone(deep = FALSE)}\if{html}{\out{
}} 658 | } 659 | 660 | \subsection{Arguments}{ 661 | \if{html}{\out{
}} 662 | \describe{ 663 | \item{\code{deep}}{Whether to make a deep clone.} 664 | } 665 | \if{html}{\out{
}} 666 | } 667 | } 668 | } 669 | -------------------------------------------------------------------------------- /man/as.ParameterSet.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ParameterSet_S3methods.R 3 | \name{as.ParameterSet} 4 | \alias{as.ParameterSet} 5 | \alias{as.ParameterSet.data.table} 6 | \alias{as.ParameterSet.prm} 7 | \alias{as.ParameterSet.list} 8 | \title{Coercions to ParameterSet} 9 | \usage{ 10 | as.ParameterSet(x, ...) 11 | 12 | \method{as.ParameterSet}{data.table}(x, ...) 13 | 14 | \method{as.ParameterSet}{prm}(x, ...) 15 | 16 | \method{as.ParameterSet}{list}(x, ...) 17 | } 18 | \arguments{ 19 | \item{x}{(\code{ANY}) \cr Object to coerce.} 20 | 21 | \item{...}{(\code{ANY}) \cr Other arguments passed to \link{ParameterSet}, such as 22 | \code{tag_properties}.} 23 | } 24 | \description{ 25 | Coercions to ParameterSet 26 | } 27 | -------------------------------------------------------------------------------- /man/as.data.table.ParameterSet.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ParameterSet_S3methods.R 3 | \name{as.data.table.ParameterSet} 4 | \alias{as.data.table.ParameterSet} 5 | \title{Coerce a ParameterSet to a data.table} 6 | \usage{ 7 | \method{as.data.table}{ParameterSet}(x, sort = TRUE, ...) 8 | } 9 | \arguments{ 10 | \item{x}{(\link{ParameterSet})} 11 | 12 | \item{sort}{(\code{logical(1)}) \cr If \code{TRUE}(default) sorts the \link{ParameterSet} 13 | alphabetically by id.} 14 | 15 | \item{...}{(\code{ANY}) \cr Other arguments, currently unused.} 16 | } 17 | \description{ 18 | Coercion from \link{ParameterSet} to \link[data.table:data.table]{data.table::data.table}. 19 | Dependencies, transformations, and tag properties are all lost in 20 | coercion. 21 | } 22 | -------------------------------------------------------------------------------- /man/as.prm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/prm.R 3 | \name{as.prm} 4 | \alias{as.prm} 5 | \alias{as.prm.ParameterSet} 6 | \alias{as.prm.data.table} 7 | \title{Coercion Methods to prm} 8 | \usage{ 9 | as.prm(x, ...) 10 | 11 | \method{as.prm}{ParameterSet}(x, ...) 12 | 13 | \method{as.prm}{data.table}(x, ...) 14 | } 15 | \arguments{ 16 | \item{x}{(\code{ANY}) \cr Object to coerce.} 17 | 18 | \item{...}{(\code{ANY}) \cr Other arguments, currently unused.} 19 | } 20 | \description{ 21 | Methods for coercing various objects to a \link{prm}. 22 | } 23 | -------------------------------------------------------------------------------- /man/c.ParameterSet.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ParameterSet_S3methods.R 3 | \name{c.ParameterSet} 4 | \alias{c.ParameterSet} 5 | \title{Concatenate Unique ParameterSet Objects} 6 | \usage{ 7 | \method{c}{ParameterSet}(..., pss = list(...)) 8 | } 9 | \arguments{ 10 | \item{...}{(\link{ParameterSet}s) \cr \link{ParameterSet} objects to concatenate.} 11 | 12 | \item{pss}{(\code{list()}) \cr Alternatively pass a list of \link{ParameterSet} 13 | objects.} 14 | } 15 | \description{ 16 | Concatenate multiple \link{ParameterSet} objects with unique ids and 17 | tags into a single \link{ParameterSet}. 18 | } 19 | \details{ 20 | Concatenates ids, tags, tag properties and dependencies. Assumes 21 | ids and tags are unique; trafos are combined into a list. 22 | } 23 | -------------------------------------------------------------------------------- /man/cnd.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/cnd.R 3 | \name{cnd} 4 | \alias{cnd} 5 | \title{Create a ParameterSet Condition} 6 | \usage{ 7 | cnd(type, value = NULL, id = NULL, error = NULL) 8 | } 9 | \arguments{ 10 | \item{type}{(\code{character(1)}) \cr 11 | The condition \code{type} determines the type of dependency to create, options 12 | are given in details.} 13 | 14 | \item{value}{(\code{ANY}) \cr 15 | If \code{id} is \code{NULL} then \code{value} should be a value in the support of the 16 | parameter that the condition is testing, that will be passed to the condition 17 | determined by \code{type}. Can be left NULL if testing if increasing/decreasing.} 18 | 19 | \item{id}{(\code{character(1)}) \cr 20 | If \code{value} is \code{NULL} then \code{id} should be the same as the id that the 21 | condition is testing, and the condition then takes the currently set value 22 | of the id in its argument. Can be left NULL if testing if increasing/decreasing.} 23 | 24 | \item{error}{(\code{character(1)}) \cr 25 | Optional error message to be displayed on fail.} 26 | } 27 | \description{ 28 | Function to create a condition for \link{ParameterSet} dependencies 29 | for use in the \verb{$deps} public method. 30 | } 31 | \details{ 32 | This function should never be used outside of creating a condition for 33 | a dependency in a \link{ParameterSet}. Currently the following conditions are 34 | supported based on the \code{type} argument, we refer to the parameter depended on 35 | as in the independent parameter, and the other as the dependent: 36 | \itemize{ 37 | \item \code{"eq"} - If \code{value} is not \code{NULL} then checks if the independent parameter 38 | equals \code{value}, otherwise checks if the independent and dependent parameter 39 | are equal. 40 | \item \code{"neq"} - If \code{value} is not \code{NULL} then checks if the independent parameter 41 | does not equal \code{value}, otherwise checks if the independent and dependent 42 | parameter are not equal. 43 | \item \code{"gt"/"lt"} - If \code{value} is not \code{NULL} then checks if the independent 44 | parameter is greater/less than \code{value}, otherwise checks if the independent 45 | parameter is greater/less than the dependent parameter. 46 | \item \code{"geq"/"leq"} - If \code{value} is not \code{NULL} then checks if the independent 47 | parameter is greater/less than or equal to \code{value}, otherwise checks if the 48 | independent parameter is greater/less than or equal to the dependent 49 | parameter. 50 | \item \code{"any"} - If \code{value} is not \code{NULL} then checks if the independent parameter 51 | equals any of \code{value}, otherwise checks if the independent parameter equals 52 | any of dependent parameter. 53 | \item \code{"nany"} - If \code{value} is not \code{NULL} then checks if the independent 54 | parameter does not equal any of \code{value}, otherwise checks if the independent 55 | parameter does not equal any of dependent parameter. 56 | \item \code{"len"} - If \code{value} is not \code{NULL} then checks if the length of the 57 | independent parameter equals \code{value}, otherwise checks if the independent 58 | and dependent parameter are the same length. 59 | \item \code{"inc"} - Checks if the parameter is increasing. 60 | \item \code{"sinc"} - Checks if the parameter is strictly increasing. 61 | \item \code{"dec"} - Checks if the parameter is decreasing. 62 | \item \code{"sdec"} - Checks if the parameter is strictly decreasing. 63 | } 64 | } 65 | -------------------------------------------------------------------------------- /man/cpset.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ParameterSet_S3methods.R 3 | \name{cpset} 4 | \alias{cpset} 5 | \title{Concatenate ParameterSet Objects} 6 | \usage{ 7 | cpset(..., pss = list(...), clone = TRUE) 8 | } 9 | \arguments{ 10 | \item{...}{(\link{ParameterSet}s) \cr Named \link{ParameterSet} objects to concatenate.} 11 | 12 | \item{pss}{(\verb{named list()}) \cr Alternatively pass a named list of 13 | \link{ParameterSet} objects.} 14 | 15 | \item{clone}{(\code{logical(1)}) \cr If \code{TRUE} (default) parameter sets are deep 16 | cloned before combination, useful to prevent original sets being prefixed.} 17 | } 18 | \description{ 19 | Concatenate multiple \link{ParameterSet} objects into a single 20 | \link{ParameterSet}. 21 | } 22 | \details{ 23 | Concatenates ids, tags, tag properties and dependencies, 24 | but not transformations. 25 | } 26 | -------------------------------------------------------------------------------- /man/expect_equal_ps.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/tools.R 3 | \name{expect_equal_ps} 4 | \alias{expect_equal_ps} 5 | \title{Check if two parameters are equal} 6 | \usage{ 7 | expect_equal_ps(obj, expected) 8 | } 9 | \arguments{ 10 | \item{obj, expected}{\link{ParameterSet}} 11 | } 12 | \description{ 13 | Primarily for internal use 14 | } 15 | -------------------------------------------------------------------------------- /man/figures/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xoopR/param6/0fa35771276fc05efe007a71bda466ced1e4c5eb/man/figures/logo.png -------------------------------------------------------------------------------- /man/length.ParameterSet.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ParameterSet_S3methods.R 3 | \name{length.ParameterSet} 4 | \alias{length.ParameterSet} 5 | \title{Length of a ParameterSet} 6 | \usage{ 7 | \method{length}{ParameterSet}(x) 8 | } 9 | \arguments{ 10 | \item{x}{(\link{ParameterSet})} 11 | } 12 | \description{ 13 | Gets the number of parameters in the \link{ParameterSet}. 14 | } 15 | -------------------------------------------------------------------------------- /man/param6-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/zzz.R 3 | \docType{package} 4 | \name{param6-package} 5 | \alias{param6} 6 | \alias{param6-package} 7 | \title{param6: A Fast and Lightweight R6 Parameter Interface} 8 | \description{ 9 | \if{html}{\figure{logo.png}{options: align='right' alt='logo' width='120'}} 10 | 11 | By making use of 'set6', alongside the S3 and R6 paradigms, this package provides a fast and lightweight R6 interface for parameters and parameter sets. 12 | } 13 | \seealso{ 14 | Useful links: 15 | \itemize{ 16 | \item \url{https://xoopR.github.io/param6/} 17 | \item \url{https://github.com/xoopR/param6/} 18 | \item Report bugs at \url{https://github.com/xoopR/param6/issues} 19 | } 20 | 21 | } 22 | \author{ 23 | \strong{Maintainer}: Raphael Sonabend \email{raphaelsonabend@gmail.com} (\href{https://orcid.org/0000-0001-9225-4654}{ORCID}) 24 | 25 | } 26 | -------------------------------------------------------------------------------- /man/prm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/prm.R 3 | \name{prm} 4 | \alias{prm} 5 | \title{S3 Parameter Constructor} 6 | \usage{ 7 | prm(id, support, value = NULL, tags = NULL, .check = TRUE) 8 | } 9 | \arguments{ 10 | \item{id}{(\code{character(1)}) \cr 11 | Parameter identifier.} 12 | 13 | \item{support}{\verb{([set6::Set]|character(1))} \cr 14 | Either a set object from 15 | \CRANpkg{set6} or a character representing the set if it is already present 16 | in the \link{support_dictionary}. If a \link[set6:Set]{set6::Set} is provided then the set and 17 | its string representation are added automatically to \link{support_dictionary} 18 | in order to provide fast internal checks. Common sets (such as the reals, 19 | naturals, etc.) are already provided in \link{support_dictionary}.} 20 | 21 | \item{value}{\code{ANY} \cr 22 | Optional to assign the parameter, will internally 23 | be checked that it lies within the given support.} 24 | 25 | \item{tags}{(\code{character()}) \cr 26 | An optional character vector of tags to apply to the parameter. On their own 27 | tags offer little extra benefit, however they can be assigned properties 28 | when creating \link{ParameterSet} objects that enable them to be more powerful.} 29 | 30 | \item{.check}{For internal use only.} 31 | } 32 | \description{ 33 | The \code{prm} class is required for \link{ParameterSet} objects, it 34 | allows specifying a parameter as a named set and optionally setting values 35 | and tags. 36 | } 37 | \examples{ 38 | library(set6) 39 | 40 | # Constructing a prm with a Set support 41 | prm( 42 | id = "a", 43 | support = Reals$new(), 44 | value = 1 45 | ) 46 | 47 | # Constructing a prm with a support already in the dictionary 48 | prm( 49 | id = "a", 50 | support = "reals", 51 | value = 1 52 | ) 53 | 54 | # Adding tags 55 | prm( 56 | id = "a", 57 | support = "reals", 58 | value = 1, 59 | tags = c("tag1", "tag2") 60 | ) 61 | } 62 | -------------------------------------------------------------------------------- /man/pset.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ParameterSet.R 3 | \name{pset} 4 | \alias{pset} 5 | \title{Convenience Function for Constructing a ParameterSet} 6 | \usage{ 7 | pset(..., prms = list(...), tag_properties = NULL, deps = NULL, trafo = NULL) 8 | } 9 | \arguments{ 10 | \item{...}{(\link{prm}) \cr \link{prm} objects.} 11 | 12 | \item{prms}{(\code{list()}) \cr List of \link{prm} objects.} 13 | 14 | \item{tag_properties}{(\code{list()}) \cr 15 | List of tag properties. Currently supported properties are: i) 'required' - 16 | parameters with this tag property must be non-NULL; ii) 'linked' - only one 17 | parameter in a linked tag group can be non-NULL and the others should be 18 | NULL, this only makes sense with an associated \code{trafo}; iii) 'unique' - 19 | parameters with this tag must have no duplicated elements, only makes sense 20 | for vector parameters; iv) 'immutable' - parameters with this tag cannot be 21 | updated after construction.} 22 | 23 | \item{deps}{(\code{list()}) \cr List of lists where each element is passed to 24 | \verb{$add_dep}. See examples.} 25 | 26 | \item{trafo}{(\verb{function()}) \cr Passed to \verb{$trafo}. See examples.} 27 | } 28 | \description{ 29 | See \link{ParameterSet} for full details. 30 | } 31 | \examples{ 32 | library(set6) 33 | 34 | # simple example 35 | prms <- list( 36 | prm("a", Set$new(1), 1, tags = "t1"), 37 | prm("b", "reals", 1.5, tags = "t1"), 38 | prm("d", "reals", 2, tags = "t2") 39 | ) 40 | p <- pset(prms = prms) 41 | 42 | # with properties, deps, trafo 43 | p <- pset( 44 | prm("a", Set$new(1), 1, tags = "t1"), 45 | prm("b", "reals", 1.5, tags = "t1"), 46 | prm("d", "reals", 2, tags = "t2"), 47 | tag_properties = list(required = "t2"), 48 | deps = list( 49 | list(id = "a", on = "b", cond = cnd("eq", 1.5)) 50 | ), 51 | trafo = function(x, self) return(x) 52 | ) 53 | } 54 | -------------------------------------------------------------------------------- /man/rep.ParameterSet.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ParameterSet_S3methods.R 3 | \name{rep.ParameterSet} 4 | \alias{rep.ParameterSet} 5 | \title{Replicate a ParameterSet} 6 | \usage{ 7 | \method{rep}{ParameterSet}(x, times, prefix, ...) 8 | } 9 | \arguments{ 10 | \item{x}{(\link{ParameterSet})} 11 | 12 | \item{times}{(\code{integer(1)}) \cr 13 | Numer of times to replicate the \code{ParameterSet}.} 14 | 15 | \item{prefix}{(\code{character(1)|character(length(times))}) \cr 16 | The prefix to add to ids and linked tags. If length \code{1} then is 17 | internally coerced to \code{paste0(prefix, seq(times))}, otherwise the length 18 | should be equal to \code{times}.} 19 | 20 | \item{...}{(\code{ANY}) \cr Other arguments, currently unused.} 21 | } 22 | \description{ 23 | In contrast to the \verb{$rep} method in \link{ParameterSet}, this method 24 | deep clones the \link{ParameterSet} and returns a new object. 25 | } 26 | \details{ 27 | In order to avoid duplicated parameter ids, every id in the 28 | \link{ParameterSet} is given a \code{prefix} in the format \code{prefix__id}. In 29 | addition, linked tags are also given the same prefix to prevent 30 | incorrectly linking parameters. 31 | 32 | The primary use-case of this method is to treat the \link{ParameterSet} as a 33 | collection of identical \link{ParameterSet} objects. 34 | } 35 | -------------------------------------------------------------------------------- /man/sub-.ParameterSet.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ParameterSet_S3methods.R 3 | \name{[.ParameterSet} 4 | \alias{[.ParameterSet} 5 | \title{Extract a sub-ParameterSet by Parameters} 6 | \usage{ 7 | \method{[}{ParameterSet}(object, ...) 8 | } 9 | \arguments{ 10 | \item{object}{(\link{ParameterSet})} 11 | 12 | \item{...}{(\code{ANY}) \cr Passed to \link{ParameterSet}$extract} 13 | } 14 | \description{ 15 | Creates a new \link{ParameterSet} by extracting the given 16 | parameters. S3 method for the \verb{$extract} public method. 17 | } 18 | -------------------------------------------------------------------------------- /man/support_dictionary.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/support_dictionary.R 3 | \name{support_dictionary} 4 | \alias{support_dictionary} 5 | \title{Support Dictionary} 6 | \description{ 7 | \link[dictionar6:Dictionary]{dictionar6::Dictionary} for parameter supports 8 | } 9 | \details{ 10 | See \link[dictionar6:Dictionary]{dictionar6::Dictionary} for full details of how to add other 11 | \link[set6:Set]{set6::Set} objects as supports to this dictionary. 12 | } 13 | \examples{ 14 | support_dictionary$keys 15 | support_dictionary$items 16 | } 17 | -------------------------------------------------------------------------------- /param6.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: No 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageRoxygenize: rd,collate,namespace 22 | -------------------------------------------------------------------------------- /tests/.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xoopR/param6/0fa35771276fc05efe007a71bda466ced1e4c5eb/tests/.DS_Store -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | test_check("param6") 3 | -------------------------------------------------------------------------------- /tests/testthat/.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xoopR/param6/0fa35771276fc05efe007a71bda466ced1e4c5eb/tests/testthat/.DS_Store -------------------------------------------------------------------------------- /tests/testthat/helpers.R: -------------------------------------------------------------------------------- 1 | expect_R6_class <- function(obj, what) { # nolint 2 | expect_true(inherits(obj, c(what, "R6"))) 3 | } 4 | -------------------------------------------------------------------------------- /tests/testthat/test-helpers.R: -------------------------------------------------------------------------------- 1 | test_that("assert_contains", { 2 | expect_silent(assert_contains(Set$new(1), 1, "ID")) 3 | expect_error(assert_contains(Set$new(1), 2, "ID"), 4 | "does not lie in support of") 5 | expect_error(assert_contains(Set$new(1), 2), "does not lie in") 6 | }) 7 | 8 | test_that("assert_no_cycles", { 9 | expect_silent(assert_no_cycles(data.table(id = "a", on = "b"))) 10 | expect_silent(assert_no_cycles(data.table(id = 1:2, on = c(3, 3)))) 11 | 12 | expect_error(assert_no_cycles(data.table(id = 1:2, on = 2:1)), 13 | "Cycles detected") 14 | expect_error(assert_no_cycles(data.table(id = 1:3, on = c(2, 3, 1))), 15 | "Cycles detected") 16 | expect_error(assert_no_cycles(data.table(id = 1:3, on = c(2, 3, 2))), 17 | "Cycles detected") 18 | }) 19 | 20 | test_that("cnd", { 21 | expect_warning(cnd("eq", 1, "a")) 22 | expect_false(eval(cnd("inc"))(list(1:2, 2:1))) 23 | expect_true(eval(cnd("inc"))(list(1:2, 1:2))) 24 | }) 25 | 26 | test_that("assert_condition", { 27 | expect_silent(assert_condition("a", Set$new(1), cnd("eq", 1))) 28 | expect_silent(assert_condition("a", Set$new(1, 2, 3), cnd("any", c(1, 2)))) 29 | 30 | expect_error(assert_condition("a", Set$new(1), cnd("eq", 2)), 31 | "Condition is not possible") 32 | expect_error(assert_condition("a", Set$new(1, 2, 3), cnd("any", c(1, 4))), 33 | "Condition is not possible") 34 | expect_error(assert_condition("a", Set$new(1), cnd("neq", 2)), 35 | "Condition is redundant") 36 | expect_error(assert_condition("a", Set$new(1, 2, 3), cnd("nany", c(1, 4))), 37 | "Condition is redundant") 38 | }) 39 | 40 | test_that("string_as_set", { 41 | expect_null(string_as_set(NULL)) 42 | expect_equal(string_as_set("a"), "{a}") 43 | expect_equal(string_as_set(c("a", "b")), "{a, b}") 44 | }) 45 | 46 | test_that("env_append", { 47 | a <- R6Class("a", 48 | public = list(b = list(), c = function() private$.c), 49 | private = list(.c = list(y = 1))) 50 | obj <- a$new() 51 | expect_silent(env_append(obj, "b", list(x = 1))) 52 | expect_silent(env_append(get_private(obj), ".c", list(z = 2))) 53 | expect_equal(obj$b, list(x = 1)) 54 | expect_equal(obj$c(), list(y = 1, z = 2)) 55 | }) 56 | 57 | test_that("invert names", { 58 | expect_equal( 59 | invert_names(list(x = "a", y = "a", z = "b")), 60 | list(a = c("x", "y"), b = "z") 61 | ) 62 | }) 63 | 64 | test_that("expand_list", { 65 | expect_equal( 66 | expand_list(letters[1:3], list(a = 1, c = 2)), 67 | list(a = 1, b = NULL, c = 2) 68 | ) 69 | expect_error(expand_list("a", list(b = 1, c = 2)), "ids in 'names'") 70 | }) 71 | 72 | test_that("named_list", { 73 | nl <- list(a = 1) 74 | expect_equal(named_list(1, "a"), nl) 75 | 76 | nl[1:2] <- NULL 77 | expect_equal(named_list(), nl) 78 | }) 79 | 80 | test_that("as_named_list", { 81 | nl <- list(a = 1, b = 2) 82 | expect_equal(as_named_list(c(1, 2), letters[1:2]), nl) 83 | 84 | nl[1:2] <- NULL 85 | expect_equal(as_named_list(), nl) 86 | }) 87 | 88 | test_that("cnd", { 89 | expect_error(cnd("a", 1), "must be one") 90 | expect_s3_class(cnd("eq", 1), "cnd") 91 | }) 92 | 93 | 94 | test_that("load_support", { 95 | expect_R6_class(load_support(), "Dictionary") 96 | }) 97 | 98 | test_that("sort_named_list", { 99 | expect_equal(sort_named_list(list(b = 1, a = 2)), 100 | list(a = 2, b = 1)) 101 | }) 102 | 103 | test_that("%nin%", { 104 | expect_false("a" %nin% letters) 105 | expect_true(1 %nin% letters) 106 | }) 107 | 108 | 109 | test_that("prefix_list", { 110 | expect_null(prefix_list(NULL)) 111 | }) 112 | 113 | 114 | test_that("assert_alphanum", { 115 | expect_equal(assert_alphanum("3439fdf"), "3439fdf") 116 | expect_error(assert_alphanum("323wdssf.df2"), "must be alphanumeric") 117 | }) 118 | -------------------------------------------------------------------------------- /tests/testthat/test-paramset.R: -------------------------------------------------------------------------------- 1 | test_that("ParameterSet constructor - silent", { 2 | prms <- list( 3 | prm("a", Set$new(1), 1, "t1"), 4 | prm("b", "reals", NULL), 5 | prm("d", "reals", 2) 6 | ) 7 | expect_R6_class(ParameterSet$new(prms), "ParameterSet") 8 | 9 | prms <- list( 10 | prm("a", Set$new(1), 1), 11 | prm("b", "reals"), 12 | prm("d", "reals") 13 | ) 14 | expect_R6_class(ParameterSet$new(prms), "ParameterSet") 15 | 16 | expect_R6_class(ParameterSet$new(), "ParameterSet") 17 | 18 | expect_R6_class(as.ParameterSet(prm("a", "reals")), "ParameterSet") 19 | }) 20 | 21 | test_that("ParameterSet constructor - error", { 22 | prms <- list( 23 | prm("a", Set$new(1), 1, "a"), 24 | prm("a", "reals", NULL), 25 | prm("d", "reals", 2) 26 | ) 27 | expect_error(ParameterSet$new(prms), "ids are not unique") 28 | 29 | prms <- list( 30 | prm("a", Set$new(1), 1, "d"), 31 | prm("b", "reals", NULL), 32 | prm("d", "reals", 2) 33 | ) 34 | expect_error(ParameterSet$new(prms), "ids and tags") 35 | }) 36 | 37 | test_that("ParamSet actives - not values or tag propeties", { 38 | prms <- list( 39 | prm("a", Set$new(1, 2), 1, c("t1", "t2")), 40 | prm("b", "reals", 2, "t2"), 41 | prm("d", "reals", 2) 42 | ) 43 | p <- ParameterSet$new(prms, list(linked = "t1", required = "t2")) 44 | 45 | expect_equal(p$tags, list(a = c("t1", "t2"), b = "t2")) 46 | expect_equal(p$ids, c("a", "b", "d")) 47 | expect_equal(length(p), 3) 48 | expect_equal( 49 | lapply(p$supports, as.character), 50 | lapply(list( 51 | a = Set$new(1, 2), b = Reals$new(), 52 | d = Reals$new() 53 | ), as.character) 54 | ) 55 | }) 56 | 57 | test_that("immutable parameters are immutable", { 58 | prms <- pset( 59 | prm("a", "reals", 1, tags = "immutable"), 60 | prm("b", "reals", 2) 61 | ) 62 | expect_equal(get_private(prms)$.immutable, list(a = 1)) 63 | prms$values$a <- NULL 64 | expect_equal(prms$values, list(a = 1, b = 2)) 65 | prms$values$a <- 2 66 | expect_equal(prms$values, list(a = 1, b = 2)) 67 | prms$values$b <- 2 68 | expect_equal(prms$values, list(a = 1, b = 2)) 69 | 70 | expect_error(prms$values <- NULL, "after construction") 71 | }) 72 | 73 | test_that("don't check immutable parameters", { 74 | prms <- pset( 75 | prm("a", "logicals", TRUE, tags = "immutable") 76 | ) 77 | prms$values$a <- 1 78 | expect_equal(prms$values$a, TRUE) 79 | }) 80 | 81 | test_that("can't set unknown parameters", { 82 | prms <- pset( 83 | prm("a", "logicals", TRUE, tags = "immutable") 84 | ) 85 | expect_error(prms$values$b <- 1, "You can't") 86 | }) 87 | 88 | test_that("ParamSet actives - values", { 89 | prms <- list( 90 | prm("a", Set$new(1, 2), 1), 91 | prm("b", "reals", NULL, "t1"), 92 | prm("d", "reals", 2, "t1") 93 | ) 94 | p <- ParameterSet$new(prms, list(linked = "t1")) 95 | 96 | expect_equal(p$values, list(a = 1, d = 2)) 97 | expect_silent(p$values$a <- 2) 98 | expect_equal(p$values$a, 2) 99 | expect_error(p$values$a <- 3, "does not") 100 | expect_equal(p$values$a, 2) 101 | expect_error(p$values <- list(a = 3, d = 1), "does not") 102 | expect_equal(p$values, list(a = 2, d = 2)) 103 | expect_silent(p$values <- list(a = 1)) 104 | expect_equal(p$values, list(a = 1)) 105 | expect_silent(p$values$a <- NULL) 106 | p$values <- list(a = 1, b = 1, d = NULL) 107 | p$values$a <- NULL 108 | expect_equal(p$values, list(b = 1)) 109 | 110 | p$values$a <- 1 111 | pri <- get_private(p) 112 | 113 | expect_warning(expect_false( 114 | .check(p, pri, supports = TRUE, deps = FALSE, tags = FALSE, 115 | error_on_fail = FALSE, value_check = list(a = 3), 116 | support_check = get_private(p)$.isupports))) 117 | 118 | p$add_dep("b", "a", cnd("eq", 1)) 119 | expect_warning(expect_false( 120 | .check(p, pri, supports = FALSE, deps = TRUE, tags = FALSE, 121 | error_on_fail = FALSE, value_check = list(b = 1, a = 3), 122 | dep_check = p$deps))) 123 | 124 | expect_warning(expect_false( 125 | .check(p, pri, supports = FALSE, deps = FALSE, tags = TRUE, 126 | id = c("b", "d"), 127 | error_on_fail = FALSE, value_check = list(b = 1, d = 1), 128 | tag_check = p$tag_properties))) 129 | expect_error(p$values <- list(a = 1, b = 1, d = 1), "Multiple linked") 130 | 131 | 132 | prms <- list( 133 | prm("b", "naturals", 1), 134 | prm("d", "naturals", 2) 135 | ) 136 | p <- ParameterSet$new(prms) 137 | expect_error(p$values <- list(b = 0.5, d = 0.5), "One or") 138 | 139 | prms <- list( 140 | prm("a", "nnaturals", 1) 141 | ) 142 | p <- ParameterSet$new(prms) 143 | expect_silent(p$values$a <- 2) 144 | expect_silent(p$values <- list(a = c(1, 2))) 145 | expect_error(p$values <- list(a = c(1, 0.5)), "does not lie") 146 | 147 | p <- pset( 148 | prm("prob", Interval$new(0, 1), 0.5, "required"), 149 | prm("qprob", Interval$new(0, 1)) 150 | ) 151 | expect_error(p$values$prob <- NULL, "Not all required") 152 | }) 153 | 154 | test_that("ParamSet actives - tag properties", { 155 | prms <- list( 156 | prm("a", Set$new(1, 2), 1, c("t1", "t2")), 157 | prm("b", "reals", 2, "t2"), 158 | prm("d", "reals", NULL, "t3") 159 | ) 160 | p <- ParameterSet$new(prms, list(linked = "t1", required = "t2")) 161 | 162 | expect_equal(p$tag_properties, list(linked = "t1", required = "t2")) 163 | expect_silent(p$tag_properties <- NULL) 164 | expect_silent(p$tag_properties$required <- "t2") 165 | expect_error(p$tag_properties <- list(required = "t3")) 166 | expect_error(p$tag_properties <- list(linked = "t2")) 167 | 168 | prms <- list( 169 | prm("a", "nreals", 1, tags = "t1"), 170 | prm("b", "nreals", 3, tags = "t2") 171 | ) 172 | p <- ParameterSet$new(prms, tag_properties = list(unique = "t1")) 173 | expect_silent(p$values$a <- 2) 174 | expect_silent(p$values <- list(a = c(1, 2))) 175 | expect_error(p$values <- list(a = c(2, 2)), "duplicated") 176 | 177 | p <- pset( 178 | prm("prob", Interval$new(0, 1), 0.5, "probs"), 179 | prm("qprob", Interval$new(0, 1), tags = "probs"), 180 | tag_properties = list(required = "probs", linked = "probs") 181 | ) 182 | expect_error(p$values$qprob <- 0.1, "Multiple linked") 183 | expect_error(p$values$prob <- NULL, "Not all required") 184 | p$values <- list(prob = NULL, qprob = 0.1) 185 | expect_error(p$values$prob <- 0.1, "Multiple linked") 186 | expect_error(p$values$qprob <- NULL, "Not all required") 187 | expect_equal(p$values, list(qprob = 0.1)) 188 | }) 189 | 190 | test_that("as.data.table.ParameterSet and print", { 191 | expect_equal( 192 | as.data.table(pset()), 193 | data.table::data.table(Id = character(), Support = list(), 194 | Value = list(), Tags = character()) 195 | ) 196 | 197 | prms <- list( 198 | prm("a", Set$new(1), 1, c("t1", "t2")), 199 | prm("b", "reals", NULL), 200 | prm("d", "reals", 2) 201 | ) 202 | p <- ParameterSet$new(prms) 203 | dtp <- as.data.table(p) 204 | expect_equal(dtp$Id, p$ids) 205 | expect_equal(drop_null(dtp$Value), unname(p$values)) 206 | expect_equal(drop_null(dtp$Tags), unname(p$tags)) 207 | Map( 208 | function(.x, .y) expect_equal(deparse(.x), deparse(.y)), 209 | dtp$Support, p$supports 210 | ) 211 | 212 | expect_output(print(p)) 213 | 214 | p$trafo <- function(x, self) x 215 | expect_warning(as.data.table(p), "Dependencies") 216 | }) 217 | 218 | test_that("as.ParameterSet.data.table", { 219 | prms <- list( 220 | prm("a", Set$new(1), 1, c("t1", "t2")), 221 | prm("b", Reals$new(), NULL), 222 | prm("d", Reals$new(), 2) 223 | ) 224 | dt <- data.table::data.table(Id = letters[c(1, 2, 4)], 225 | Support = list(Set$new(1), Reals$new(), 226 | Reals$new()), 227 | Value = list(1, NULL, 2), 228 | Tags = list(c("t1", "t2"), NULL, NULL)) 229 | expect_equal_ps(as.ParameterSet(dt), ParameterSet$new(prms)) 230 | 231 | prms <- list( 232 | prm("a", "naturals", 1, c("t1", "t2")), 233 | prm("b", "reals", NULL), 234 | prm("d", "reals", 2) 235 | ) 236 | dt <- data.table::data.table(Id = letters[c(1, 2, 4)], 237 | Support = list("naturals", "reals", "reals"), 238 | Value = list(1, NULL, 2), 239 | Tags = list(c("t1", "t2"), NULL, NULL)) 240 | expect_equal_ps(as.ParameterSet(dt), ParameterSet$new(prms)) 241 | }) 242 | 243 | test_that("get_values", { 244 | prms <- list( 245 | prm("a", Set$new(1), 1, tags = "t1"), 246 | prm("b", "reals", tags = "t1"), 247 | prm("d", "reals", tags = "t2") 248 | ) 249 | p <- ParameterSet$new(prms) 250 | expect_equal(p$get_values(inc_null = TRUE), list(a = 1, b = NULL, d = NULL)) 251 | expect_equal(p$get_values(inc_null = FALSE, simplify = FALSE), list(a = 1)) 252 | 253 | expect_equal(p$get_values(inc_null = TRUE, tags = "t1"), 254 | list(a = 1, b = NULL)) 255 | expect_equal(p$get_values(inc_null = FALSE, tags = "t1"), 1) 256 | expect_equal(p$get_values(inc_null = FALSE, tags = "t1", simplify = FALSE), 257 | list(a = 1)) 258 | 259 | expect_equal(p$get_values(inc_null = TRUE, tags = "t2"), NULL) 260 | expect_equal(p$get_values(inc_null = FALSE, tags = "t2", simplify = FALSE), 261 | list()) 262 | 263 | prms <- list( 264 | prm("Pre1__par1", Set$new(1), 1, tags = "t1"), 265 | prm("Pre1__par2", "reals", 2, tags = "t2"), 266 | prm("Pre2__par1", Set$new(1), 1, tags = "t1"), 267 | prm("Pre2__par2", "reals", tags = "t2") 268 | ) 269 | p <- ParameterSet$new(prms) 270 | expect_equal(p$get_values("Pre1__"), list(Pre1__par1 = 1, Pre1__par2 = 2)) 271 | expect_equal(p$get_values(c("Pre1__", "Pre2__")), 272 | list(Pre1__par1 = 1, Pre1__par2 = 2, Pre2__par1 = 1, 273 | Pre2__par2 = NULL)) 274 | expect_equal(p$get_values("par1"), list(Pre1__par1 = 1, Pre2__par1 = 1)) 275 | 276 | p <- pset( 277 | prm("elements", "universal", 1), 278 | prm("probs", Interval$new(0, 1)^"n", 1) 279 | ) 280 | p$values <- list(elements = c(1, 0), probs = c(0.4, 0.9)) 281 | expect_equal(p$values, list(elements = c(1, 0), probs = c(0.4, 0.9))) 282 | expect_equal(p$get_values(), list(elements = c(1, 0), probs = c(0.4, 0.9))) 283 | }) 284 | 285 | test_that("trafo", { 286 | prms <- list( 287 | prm("a", Set$new(1, 2), 1, tags = "t1"), 288 | prm("b", "reals", tags = "t1"), 289 | prm("d", "reals", tags = "t2") 290 | ) 291 | p <- ParameterSet$new(prms) 292 | expect_equal(p$trafo, NULL) 293 | expect_equal(get_private(p)$.trafo, NULL) 294 | expect_error(p$trafo <- "a", "function") 295 | expect_error(p$trafo <- function(x, self) "a", "list") 296 | expect_silent({ 297 | p$trafo <- function(x, self) { 298 | x$a <- x$a + 1 299 | x$b <- 3 300 | x 301 | } 302 | }) 303 | expect_error({ 304 | p$trafo <- function(x, self) { 305 | x$a <- x$a + 2 306 | x$b <- 3 307 | x 308 | } 309 | }, "One or more") 310 | expect_equal(p$get_values(inc_null = FALSE), list(a = 2, b = 3)) 311 | 312 | prms <- list( 313 | prm("a", Set$new(1, exp(1)), 1, tags = "t1"), 314 | prm("b", "reals", 2, tags = "t1"), 315 | prm("d", "reals", tags = "t2") 316 | ) 317 | p <- ParameterSet$new(prms) 318 | p$trafo <- function(x, self) { 319 | x <- lapply(self$get_values(tags = "t1", transform = FALSE), exp) 320 | x 321 | } 322 | expect_equal(p$get_values(inc_null = FALSE), list(a = exp(1), b = exp(2))) 323 | 324 | p <- ParameterSet$new( 325 | list(prm(id = "a", 2, support = Reals$new(), tags = "t1"), 326 | prm(id = "b", 3, support = Reals$new(), tags = "t1"), 327 | prm(id = "d", 4, support = Reals$new())) 328 | ) 329 | p$trafo <- function(x, self) { 330 | out <- lapply( 331 | self$get_values(tags = "t1", transform = FALSE), 332 | function(.x) 2^.x 333 | ) 334 | out <- c(out, list(d = x$d)) 335 | out 336 | } 337 | expect_equal(p$get_values(), list(a = 4, b = 8, d = 4)) 338 | 339 | p <- pset( 340 | prm("prob", Interval$new(0, 1), 0.5, "probs"), 341 | prm("qprob", Interval$new(0, 1), tags = "probs"), 342 | tag_properties = list(linked = "probs"), 343 | trafo = function(x, self) { 344 | if (is.null(x$prob)) { 345 | x$prob <- 1 - x$qprob 346 | } 347 | if (is.null(x$qprob)) { 348 | x$qprob <- 1 - x$prob 349 | } 350 | x 351 | } 352 | ) 353 | p$values$prob <- 0.2 354 | expect_equal(p$get_values(), list(prob = 0.2, qprob = 0.8)) 355 | }) 356 | 357 | test_that("rep", { 358 | prms <- list( 359 | prm("par1", Set$new(1), 1, tags = "t1"), 360 | prm("par2", "reals", 3, tags = "t2"), 361 | prm("par3", "reals", 4, tags = "immutable") 362 | ) 363 | p1 <- ParameterSet$new(prms, tag_properties = list(required = "t1", 364 | linked = "t2")) 365 | 366 | prms <- list( 367 | prm("Pre1__par1", Set$new(1), 1, tags = "t1"), 368 | prm("Pre1__par2", "reals", 3, tags = "t2"), 369 | prm("Pre1__par3", "reals", 4, tags = "immutable"), 370 | prm("Pre2__par1", Set$new(1), 1, tags = "t1"), 371 | prm("Pre2__par2", "reals", 3, tags = "t2"), 372 | prm("Pre2__par3", "reals", 4, tags = "immutable") 373 | ) 374 | p2 <- ParameterSet$new( 375 | prms, 376 | tag_properties = list(required = "t1", linked = "t2") 377 | ) 378 | 379 | expect_equal_ps(p1$rep(2, "Pre"), p2) 380 | expect_error(p1$rep(3, letters[1:2]), "either be") 381 | 382 | prms <- list( 383 | prm("par1", Set$new(1), 1, tags = "t1"), 384 | prm("par2", "reals", 3, tags = "t2"), 385 | prm("par3", "reals", 4, tags = "immutable") 386 | ) 387 | p1 <- ParameterSet$new(prms, tag_properties = list(required = "t1", 388 | linked = "t2")) 389 | expect_equal_ps(rep(p1, 2, "Pre"), p2) 390 | expect_equal(length(p1), 3) 391 | }) 392 | 393 | test_that("add_dep", { 394 | prms <- list( 395 | prm("a", Set$new(1), 1, tags = "t1"), 396 | prm("b", "reals", tags = "t1"), 397 | prm("d", "reals", tags = "t2") 398 | ) 399 | p <- ParameterSet$new(prms) 400 | expect_error(p$add_dep("a", "b", cnd("eq", 1)), "failed") 401 | expect_error(p$add_dep("a", "a", cnd("eq", 1)), "themselves") 402 | expect_silent(p$add_dep("b", "a", cnd("eq", 1))) 403 | expect_error(p$add_dep("b", "a", cnd("eq", 1)), "already depends") 404 | p$values$b <- 3 405 | expect_error(p$values$a <- NULL, "failed") 406 | 407 | 408 | prms <- list( 409 | prm("Pre1__par1", Set$new(1), 1, tags = "t1"), 410 | prm("Pre1__par2", "reals", 3, tags = "t2"), 411 | prm("Pre2__par1", Set$new(1), 1, tags = "t1"), 412 | prm("Pre2__par2", "reals", 3, tags = "t2") 413 | ) 414 | p2 <- ParameterSet$new(prms) 415 | expect_error(p2$add_dep("par1", "par2", cnd("any", 1:2)), "Dependency of") 416 | expect_silent(p2$add_dep("par1", "par2", cnd("eq", 3))) 417 | expect_error(p2$add_dep("Pre1", "Pre2", cnd("eq", 3)), "subset of") 418 | 419 | prms <- list( 420 | prm("a", "nreals", 1, tags = "t1"), 421 | prm("b", "nreals", 2, tags = "t1"), 422 | prm("d", "nreals", 3, tags = "t2") 423 | ) 424 | p <- ParameterSet$new(prms) 425 | p$add_dep("a", "b", cnd("lt", id = "b")) 426 | expect_error(p$values$a <- 2, "a < b") 427 | p$add_dep("a", "d", cnd("len", id = "d")) 428 | expect_error(p$values$d <- c(1, 2), "a len d") 429 | expect_error(p$add_dep("a", "d", cnd("len", id = "b")), "element of set") 430 | 431 | prms <- list( 432 | prm("a", "nreals", 1:2, tags = "t1"), 433 | prm("b", "nreals", 2, tags = "t1"), 434 | prm("d", "nreals", 3, tags = "t2") 435 | ) 436 | p <- ParameterSet$new(prms) 437 | p$add_dep("b", "a", cnd("len", 2)) 438 | expect_error(p$values$a <- 1, "b on 'a") 439 | t}) 440 | 441 | test_that("c", { 442 | prms <- list( 443 | prm("a", Set$new(1, 2), 1, c("t1", "t2")), 444 | prm("b", "reals", NULL, "t3"), 445 | prm("d", "reals", 2), 446 | prm("e", "reals", 2) 447 | ) 448 | p <- ParameterSet$new(prms, list(required = "t1", linked = "t2")) 449 | 450 | p1 <- ParameterSet$new(list(prm("a", Set$new(1, 2), 1, c("t1", "t2"))), 451 | list(required = "t1", linked = "t2")) 452 | p2 <- ParameterSet$new(list(prm("b", "reals", NULL, "t3"))) 453 | p3 <- ParameterSet$new(list(prm("d", "reals", 2), prm("e", "reals", 2))) 454 | p4 <- ParameterSet$new(list(prm("e", "reals", 1, "t1")), 455 | list(linked = "t1")) 456 | 457 | expect_error(c(p1, p4), "inconsistent") 458 | expect_equal(as.data.table(c(p1, p2, p3)), as.data.table(p)) 459 | expect_equal(p$tag_properties, c(p1, p2)$tag_properties) 460 | expect_equal(c(p2, p3)$tag_properties, NULL) 461 | 462 | prms <- list( 463 | prm("a", "reals", 2), 464 | prm("b", "reals", 2), 465 | prm("d", "reals"), 466 | prm("e", "reals") 467 | ) 468 | p <- ParameterSet$new(prms) 469 | p$add_dep("a", "b", cnd("neq", 1)) 470 | p$trafo <- function(x, self) { 471 | x$d <- 2 472 | x 473 | } 474 | 475 | p1 <- ParameterSet$new(list(prm("a", "reals", 2), prm("b", "reals", 2))) 476 | p1$add_dep("a", "b", cnd("neq", 1)) 477 | p2 <- ParameterSet$new(list(prm("d", "reals"), prm("e", "reals"))) 478 | p2$trafo <- function(x, self) { 479 | x$d <- 2 480 | x 481 | } 482 | expect_equal_ps(c(p1, p2), p) 483 | }) 484 | 485 | test_that("extract - no deps", { 486 | p <- pset( 487 | prm("Pre1__par1", Set$new(1), 1, tags = "t1"), 488 | prm("Pre1__par2", "reals", 3, tags = "t2"), 489 | prm("Pre2__par1", Set$new(1), 1, tags = "t1"), 490 | prm("Pre2__par2", "reals", 3, tags = "t2") 491 | ) 492 | 493 | prms <- list( 494 | prm("par1", Set$new(1), 1, tags = "t1"), 495 | prm("par2", "reals", 3, tags = "t2") 496 | ) 497 | p2 <- ParameterSet$new(prms) 498 | expect_equal_ps(p$extract(prefix = "Pre1"), p2) 499 | expect_error(p$extract(), "One argument") 500 | 501 | prms <- list( 502 | prm("Pre1__par1", Set$new(1), 1), 503 | prm("Pre1__par2", "reals", 3), 504 | prm("Pre2__par1", Set$new(1), 1), 505 | prm("Pre2__par2", "reals", 3) 506 | ) 507 | p3 <- ParameterSet$new(prms) 508 | prms <- list( 509 | prm("par1", Set$new(1), 1), 510 | prm("par2", "reals", 3) 511 | ) 512 | p4 <- ParameterSet$new(prms) 513 | expect_equal_ps(p3$extract(prefix = "Pre1"), p4) 514 | 515 | prms <- list( 516 | prm("Pre1__par1", Set$new(1), 1, tags = "t1"), 517 | prm("Pre2__par1", Set$new(1), 1, tags = "t1") 518 | ) 519 | p2 <- ParameterSet$new(prms) 520 | expect_equal_ps(p$extract("par1"), p2) 521 | expect_error(p$extract("par1", prefix = "A"), "must be NULL") 522 | 523 | prms <- list( 524 | prm("Pre1__par1", Set$new(1), 1, tags = "t1") 525 | ) 526 | p2 <- ParameterSet$new(prms) 527 | expect_equal_ps(p$extract("Pre1__par1"), p2) 528 | 529 | prms <- list( 530 | prm("Pre1__par1", Set$new(1), 1, tags = "t1"), 531 | prm("Pre1__par2", "reals", 3, tags = "t2"), 532 | prm("Pre2__par1", Set$new(1), 1, tags = "t1"), 533 | prm("Pre2__par2", "reals", 3, tags = "t2") 534 | ) 535 | p <- ParameterSet$new(prms, list(linked = "t1", required = "t2")) 536 | 537 | prms <- list( 538 | prm("par1", Set$new(1), 1, tags = "t1"), 539 | prm("par2", "reals", 3, tags = "t2") 540 | ) 541 | p2 <- ParameterSet$new(prms, list(linked = "t1", required = "t2")) 542 | expect_equal_ps(p$extract(prefix = "Pre1"), p2) 543 | 544 | prms <- list( 545 | prm("a__par1", Set$new(1)), 546 | prm("b__par2", "reals") 547 | ) 548 | p <- ParameterSet$new(prms) 549 | p$trafo <- list(a = function(x, self) x) 550 | expect_equal(p[prefix = "a"]$trafo, list(a = function(x, self) x)) 551 | 552 | prms <- list( 553 | prm("a__par1", Set$new(1)), 554 | prm("b__par2", "reals") 555 | ) 556 | p <- ParameterSet$new(prms) 557 | p$trafo <- list(function(x, self) x) 558 | expect_equal(p[prefix = "a"]$trafo, function(x, self) x) 559 | 560 | prms <- list( 561 | prm("a__par1", Set$new(1)), 562 | prm("b__par2", "reals") 563 | ) 564 | p <- ParameterSet$new(prms) 565 | p$trafo <- function(x, self) x 566 | expect_equal(p[prefix = "a"]$trafo, function(x, self) x) 567 | }) 568 | 569 | test_that("extract - deps", { 570 | prms <- list( 571 | prm("a", Set$new(1), 1, tags = "t1"), 572 | prm("b", "reals", tags = "t1"), 573 | prm("d", "reals", 2, tags = "t2") 574 | ) 575 | p <- ParameterSet$new(prms) 576 | p$add_dep("b", "a", cnd("eq", 1)) 577 | p$add_dep("a", "d", cnd("gt", 0)) 578 | 579 | expect_equal(p$extract("a")$deps, NULL) 580 | expect_equal(p$extract(letters[1:2])$deps, 581 | data.table::data.table(id = "b", on = "a", 582 | cond = list(cnd("eq", 1)))) 583 | 584 | prms <- list( 585 | prm("Pre1__par1", Set$new(1), 1, tags = "t1"), 586 | prm("Pre1__par2", "reals", 3, tags = "t2"), 587 | prm("Pre2__par1", Set$new(1), 1, tags = "t1"), 588 | prm("Pre2__par2", "reals", 3, tags = "t2") 589 | ) 590 | p <- ParameterSet$new(prms) 591 | p$add_dep("Pre1__par1", "Pre1__par2", cnd("eq", 3)) 592 | expect_equal(p$extract(prefix = "Pre1")$deps, 593 | data.table::data.table(id = "par1", on = "par2", 594 | cond = list(cnd("eq", 3)))) 595 | 596 | }) 597 | 598 | test_that("deep clone", { 599 | p <- pset( 600 | prm("a", Set$new(1), 1, tags = "t1"), 601 | prm("b", "reals", 1.5, tags = "t1"), 602 | prm("d", "reals", 2, tags = "t2") 603 | ) 604 | p$add_dep("a", "b", cnd("eq", 1.5)) 605 | p2 <- p$clone(deep = TRUE) 606 | p2$values$d <- 3 607 | expect_true(p$values$d != p2$values$d) 608 | 609 | p3 <- p 610 | p3$values$d <- 3 611 | expect_true(p$values$d == p3$values$d) 612 | }) 613 | 614 | 615 | test_that("transformations error when expected and don't otherwise", { 616 | trafo <- function(x, self) { 617 | size <- ifelse(is.null(x$size), self$values$size, x$size) 618 | if (!is.null(x$successes)) { 619 | x$failures <- size - x$successes 620 | } else if (!is.null(x$failures)) { 621 | x$successes <- size - x$failures 622 | } 623 | x 624 | } 625 | 626 | p <- pset( 627 | prm("size", "naturals", 50), 628 | prm("successes", Set$new(0:50, class = "integer")), 629 | prm("failures", Set$new(0:50, class = "integer"), 45), 630 | prm("draws", Set$new(0:50, class = "integer"), 10, tags = "required"), 631 | deps = list( 632 | list(id = "successes", on = "size", cond = cnd("leq", id = "size")), 633 | list(id = "failures", on = "size", cond = cnd("leq", id = "size")) 634 | ), 635 | trafo = trafo 636 | ) 637 | p$values <- list(size = 40, failures = 2, draws = 5) 638 | expect_equal(p$values, list(draws = 5, failures = 2, size = 40)) 639 | expect_error(p$values$failures <- 60, "does not lie in") 640 | expect_equal(p$trafo, trafo) 641 | 642 | trafo_bad <- function(x, self) { 643 | x$failures <- Inf 644 | x 645 | } 646 | 647 | expect_error(p$trafo <- trafo_bad, "does not lie in") 648 | expect_equal(p$trafo, trafo) 649 | }) 650 | 651 | 652 | test_that("transform types", { 653 | trafo_a <- function(x, self) { 654 | x$a <- x$a + 1 655 | x 656 | } 657 | trafo_b <- function(x, self) { 658 | x$b <- x$b + 1 659 | x 660 | } 661 | p <- pset( 662 | prm("a", "reals", 2), 663 | prm("b", "reals", 1), 664 | trafo = trafo_a 665 | ) 666 | expect_equal(p$transform(), list(a = 3, b = 1)) 667 | 668 | p$trafo <- list(trafo_a, trafo_b) 669 | expect_equal(p$transform(), list(a = 3, b = 2)) 670 | expect_equal(p$transform(p$values), list(a = 3, b = 2)) 671 | 672 | p$trafo <- NULL 673 | expect_equal(p$transform(), list(a = 2, b = 1)) 674 | 675 | p <- pset(prm("a", "reals", 1), trafo = list(function(x, self) x)) 676 | expect_true(is.function(p$trafo)) 677 | p <- pset(prm("a", "reals", 1), trafo = list(a = function(x, self) x)) 678 | expect_equal(p$trafo, list(a = function(x, self) x)) 679 | }) 680 | 681 | 682 | test_that("rep cnd works", { 683 | p <- pset( 684 | prm("elements", "universal", 1, tags = "required"), 685 | prm("probs", Interval$new(0, 1)^"n", 1, tags = "required"), 686 | deps = list( 687 | list(id = "probs", on = "elements", cond = cnd("len", id = "elements")) 688 | ) 689 | )$rep(2, "A") 690 | expect_error(p$values$A1__elements <- 1:2) # nolint 691 | new_p <- list(A1__elements = 1:2, A1__probs = runif(2), A2__elements = 1, 692 | A2__probs = 1) 693 | p$values <- new_p 694 | expect_equal(p$values, new_p) 695 | }) 696 | 697 | 698 | test_that("can extract with trafo, properties, deps", { 699 | trafo_probs <- function(x, self) { 700 | probs <- x[grepl("prob", names(x))] 701 | qprobs <- x[grepl("qprob", names(x))] 702 | c(x, 703 | setNames( 704 | as.list(1 - unlist(probs)), 705 | gsub("prob", "qprob", names("prob")) 706 | ) 707 | ) 708 | } 709 | p <- pset( 710 | prm("prob", Interval$new(0, 1), 0.5, tags = c("probs", "r")), 711 | prm("qprob", Interval$new(0, 1), tags = c("probs", "r")), 712 | prm("size", "posnaturals", 10, tags = "r"), 713 | tag_properties = list(linked = "probs", required = "r"), 714 | trafo = trafo_probs, 715 | deps = list( 716 | list(id = "prob", on = "size", cond = cnd("len", id = "size")), 717 | list(id = "qprob", on = "size", cond = cnd("len", id = "size")) 718 | ) 719 | ) 720 | p2 <- p$clone(deep = TRUE)$rep(2, "p") 721 | p_ext <- p2[prefix = "p1"] 722 | expect_equal_ps(p, p_ext) 723 | }) 724 | 725 | 726 | test_that("concatenate named list", { 727 | p <- pset( 728 | prm("a", "reals", 1, tags = "unique"), 729 | prm("b", "reals", 1, tags = "immutable"), 730 | prm("d", "reals", 1, tags = "linked"), 731 | deps = list(list(id = "a", on = "b", cond = cnd("eq", id = "b"))) 732 | ) 733 | lst <- list(a = p, b = p$clone(deep = TRUE)) 734 | cp <- cpset(pss = lst) 735 | 736 | pexp <- pset( 737 | prm("a__a", "reals", 1, tags = "unique"), 738 | prm("a__b", "reals", 1, tags = "immutable"), 739 | prm("b__a", "reals", 1, tags = "unique"), 740 | prm("b__b", "reals", 1, tags = "immutable"), 741 | prm("a__d", "reals", 1, tags = "a__linked"), 742 | prm("b__d", "reals", 1, tags = "b__linked"), 743 | tag_properties = list(linked = c("a__linked", "b__linked")), 744 | deps = list( 745 | list(id = "a__a", on = "a__b", cond = cnd("eq", id = "a__b")), 746 | list(id = "b__a", on = "b__b", cond = cnd("eq", id = "b__b")) 747 | ) 748 | ) 749 | 750 | expect_equal_ps(cp, pexp) 751 | }) 752 | 753 | 754 | test_that("linked + required works as expected", { 755 | p <- pset( 756 | prm("prob", Interval$new(0, 1), 1, tags = c("linked", "required")), 757 | prm("qprob", Interval$new(0, 1), tags = c("linked", "required")), 758 | prm("size", "posnaturals", 10, tags = "required") 759 | ) 760 | expect_error(p$values$prob <- NULL, "Not all required") 761 | expect_error(p$values <- list(size = 10, prob = NULL), "Not all required") 762 | p$values <- list(size = 1, prob = NULL, qprob = 1) 763 | expect_equal(p$values, list(qprob = 1, size = 1)) 764 | }) 765 | 766 | 767 | test_that("can update support", { 768 | p <- pset( 769 | prm("a", "reals", 1), 770 | prm("b", "reals", 1) 771 | ) 772 | sup <- list(a = Interval$new(0, 5), b = Interval$new(1, 3)) 773 | get_private(p)$.update_support(lst = sup) 774 | expect_equal(as.character(p$supports), as.character(sup)) 775 | }) 776 | 777 | 778 | test_that("can remove a parameter", { 779 | p1 <- pset( 780 | prm("a", "reals", 1), 781 | prm("b", "reals", 1) 782 | ) 783 | expect_error(p1$remove(c("a", "b"))) 784 | p2 <- pset( 785 | prm("a", "reals", 1) 786 | ) 787 | p3 <- pset( 788 | prm("c__a", "posreals", 1, c("required", "immutable")), 789 | prm("d__b", "reals", 1), 790 | trafo = list(c__a = function(x, self) x), 791 | deps = list(list(id = "c__a", on = "d__b", cond = cnd("eq", 1))) 792 | ) 793 | p4 <- pset( 794 | prm("d__b", "reals", 1) 795 | ) 796 | 797 | expect_equal_ps(p3$remove(prefix = "c"), p4) 798 | expect_equal_ps(p1$remove("b"), p2) 799 | 800 | expect_error(p2$remove(), "Exactly one") 801 | 802 | p1 <- pset( 803 | prm("a__a", "reals", 1), 804 | prm("b__b", "reals", 1), 805 | trafo = list(b = function(x, self) x, function(x, self) 1) 806 | ) 807 | p1$remove("b") 808 | expect_equal(p1$trafo, function(x, self) 1) 809 | }) 810 | 811 | 812 | test_that("set_values", { 813 | p <- pset( 814 | prm("a", "reals", 1), 815 | prm("b", "reals", 1) 816 | ) 817 | p$set_values(b = 2) 818 | expect_equal(p$values, list(a = 1, b = 2)) 819 | }) 820 | 821 | 822 | test_that("update_ids", { 823 | p1 <- pset( 824 | prm("a", "reals", 1, tags = "unique"), 825 | prm("b", "reals", 1, tags = "immutable"), 826 | prm("d", "reals", 1, tags = "linked"), 827 | trafo = list(a = function(x, self) x), 828 | deps = list(list(id = "a", on = "b", cond = cnd("eq", id = "b"))) 829 | ) 830 | get_private(p1)$.prefix("a") 831 | p2 <- pset( 832 | prm("a__a", "reals", 1, tags = "unique"), 833 | prm("a__b", "reals", 1, tags = "immutable"), 834 | prm("a__d", "reals", 1, tags = "a__linked"), 835 | tag_properties = list(linked = "a__linked"), 836 | trafo = list(a__a = function(x, self) x), 837 | deps = list(list(id = "a__a", on = "a__b", cond = cnd("eq", id = "a__b"))) 838 | ) 839 | expect_equal_ps(p1, p2) 840 | }) 841 | 842 | 843 | test_that("can auto add tags to manual", { 844 | p <- pset( 845 | prm("a", "reals", 1, tags = "unique"), 846 | prm("b", "reals", 1, tags = "bunique"), 847 | tag_properties = list(unique = "bunique") 848 | ) 849 | expect_equal(p$tag_properties, list(unique = c("bunique", "unique"))) 850 | }) 851 | 852 | test_that("unprefix(prefix(ps)) is ps", { 853 | p <- pset( 854 | prm("a", "reals", 1, tags = "linked"), 855 | prm("b", "reals", 1), 856 | trafo = list(a = function(x, self) x) 857 | ) 858 | p2 <- p$clone(deep = TRUE) 859 | get_private(p)$.prefix("pre") 860 | get_private(p)$.unprefix() 861 | expect_equal_ps(p, p2) 862 | }) 863 | 864 | 865 | test_that("checks work for cond(eq = TRUE)", { 866 | p <- pset( 867 | prm("a", "logicals", FALSE), 868 | prm("b", "reals"), 869 | deps = list(list(id = "b", on = "a", cond = cnd("eq", TRUE))) 870 | ) 871 | 872 | expect_error(p$values$b <- 2) 873 | p$values$a <- TRUE 874 | p$values$b <- 2 875 | expect_error(p$values$a <- FALSE) 876 | }) 877 | 878 | 879 | test_that("checks work for cond inc/dec", { 880 | p <- pset( 881 | prm("a", "nreals"), 882 | deps = list(list(id = "a", cond = cnd("inc"))) 883 | ) 884 | p$values$a <- 1:3 885 | p$values$a <- c(3, 3, 3) 886 | expect_error(p$values$a <- c(3, 3, 2), "not increasing") 887 | 888 | p <- pset( 889 | prm("a", "nreals") 890 | ) 891 | p$add_dep("a", NULL, cnd("sinc")) 892 | p$values$a <- 1:3 893 | expect_error(p$values$a <- c(3, 3, 4), "not strictly increasing") 894 | 895 | p <- pset( 896 | prm("a", "nreals"), 897 | deps = list(list(id = "a", cond = cnd("dec"))) 898 | ) 899 | p$values$a <- 3:1 900 | p$values$a <- c(3, 3, 3) 901 | expect_error(p$values$a <- c(3, 3, 4), "not decreasing") 902 | 903 | p <- pset( 904 | prm("a", "nreals"), 905 | deps = list(list(id = "a", cond = cnd("sdec"))) 906 | ) 907 | p$values$a <- 3:1 908 | expect_error(p$values$a <- c(3, 3, 2), "not strictly decreasing") 909 | }) 910 | 911 | test_that("checks multiple conditions can work/fail", { 912 | p <- pset( 913 | prm("a", "nreals"), 914 | prm("b", "nreals"), 915 | deps = list( 916 | list(id = "a", cond = cnd("inc", error = "custom error")), 917 | list(id = "a", on = "b", cond = cnd("len", id = "b")) 918 | ) 919 | ) 920 | expect_error(p$values$a <- 3:1, "custom error") 921 | expect_error(p$values <- list(a = 1, b = 1:2), "len") 922 | expect_error(p$values <- list(a = 3:1, b = 1:3), "custom error") 923 | p$values <- list(a = 1:3, b = 1:3) 924 | expect_error(p$values <- list(a = 1:2, b = 1:3), "len") 925 | }) 926 | -------------------------------------------------------------------------------- /tests/testthat/test-prm.R: -------------------------------------------------------------------------------- 1 | test_that("prm", { 2 | expect_equal( 3 | unclass(prm("a", Set$new(1), 1, "a")), 4 | list(id = "a", support = "{1}", value = 1, tags = "a") 5 | ) 6 | expect_true(support_dictionary$has("{1}")) 7 | expect_equal( 8 | unclass(prm("a", Set$new(1), 1, "a")), 9 | list(id = "a", support = "{1}", value = 1, tags = "a") 10 | ) 11 | 12 | expect_equal( 13 | unclass(prm("a", "reals", 1, "a")), 14 | list(id = "a", support = "reals", value = 1, tags = "a") 15 | ) 16 | 17 | expect_equal( 18 | unclass(prm("a", "reals")), 19 | list(id = "a", support = "reals", value = NULL, tags = NULL) 20 | ) 21 | 22 | expect_equal( 23 | unclass(prm("a", "reals", tags = letters[1:2])), 24 | list(id = "a", support = "reals", value = NULL, tags = letters[1:2]) 25 | ) 26 | 27 | expect_equal(class(prm("a", "reals")), "prm") 28 | }) 29 | 30 | test_that("prm - error", { 31 | expect_error(prm("a", Set$new(1), tags = "c"), "'c' is a") 32 | expect_error(prm("c", "reals", 2), "'c' is a") 33 | 34 | expect_error(prm("a", "Reals", 1, "a"), "does not exist") 35 | expect_error(prm("a", 1, 1, "a"), "character scalar") 36 | }) 37 | 38 | test_that("required prm", { 39 | expect_silent(prm("a", Set$new(1), 1, "required")) 40 | }) 41 | 42 | test_that("as.prm.data.table", { 43 | prms <- list( 44 | prm("a", Set$new(1), 1, letters[1:2]), 45 | prm("b", Reals$new(), NULL), 46 | prm("d", Reals$new(), 2) 47 | ) 48 | dt <- data.table::data.table(Id = letters[c(1, 2, 4)], 49 | Support = list(Set$new(1), Reals$new(), 50 | Reals$new()), 51 | Value = list(1, NULL, 2), 52 | Tags = list(letters[1:2], NULL, NULL)) 53 | expect_equal(as.prm(dt), prms) 54 | 55 | prms <- list( 56 | prm("a", "naturals", 1, letters[1:2]), 57 | prm("b", "reals", NULL), 58 | prm("d", "reals", 2) 59 | ) 60 | dt <- data.table::data.table(Id = letters[c(1, 2, 4)], 61 | Support = list("naturals", "reals", "reals"), 62 | Value = list(1, NULL, 2), 63 | Tags = list(letters[1:2], NULL, NULL)) 64 | expect_equal(as.prm(dt), prms) 65 | }) 66 | 67 | test_that("as.prm.ParameterSet", { 68 | prms <- list( 69 | prm("a", Set$new(1), 1), 70 | prm("b", "reals"), 71 | prm("d", "reals") 72 | ) 73 | expect_equal(as.prm(as.ParameterSet(prms)), prms) 74 | }) 75 | test_that("deep clone", { 76 | d1 <- Dictionary$new(a = Set$new(1), d = 1) 77 | d2 <- d1$clone(deep = TRUE) 78 | d3 <- d1 79 | d2$add(list(b = 2)) 80 | expect_equal(length(d1), length(d3)) 81 | expect_false(length(d1) == length(d2)) 82 | }) 83 | -------------------------------------------------------------------------------- /todo/ParameterSet_helpers.R: -------------------------------------------------------------------------------- 1 | .check_custom <- function(self, values, checks, id, error_on_fail) { 2 | if (!is.null(checks) && nrow(checks)) { 3 | if (!is.null(id)) { 4 | ids <- NULL 5 | checks <- subset(checks, grepl(paste0(id, collapse = "|"), ids)) 6 | } 7 | 8 | # `for` instead of `vapply` allows early breaking 9 | for (i in seq_along(checks$fun)) { 10 | .y <- checks$fun[[i]] 11 | ivalues <- .get_values(self, get_private(self), values, checks$ids[[i]], 12 | checks$tags[[i]]) 13 | ok <- as.function(list(x = ivalues, self = self, .y))() 14 | if (!ok) { 15 | return(.return_fail(sprintf("Check on '%s' failed.", deparse(.y)), 16 | error_on_fail)) 17 | } 18 | } 19 | } 20 | 21 | return(TRUE) 22 | } -------------------------------------------------------------------------------- /todo/ParameterSet_methods.R: -------------------------------------------------------------------------------- 1 | # This method is finished and can be added at anytime. However I am 2 | # generally unsure if/when `add`/`remove` methods are required. 3 | .ParameterSet__add <- function(self, private, prms) { # nolint 4 | if (length(prms)) { 5 | checkmate::assert_list(prms, "prm6", any.missing = FALSE) 6 | 7 | ids <- vapply(prms, "[[", character(1), "id") 8 | names(prms) <- ids 9 | if (any(duplicated(c(ids, private$.id)))) { 10 | stop("ids are not unique or already existed in ParameterSet.") 11 | } else { 12 | env_append(private, ".id", ids) 13 | env_append(private, ".supports", 14 | vapply(prms, "[[", character(1), "support")) 15 | env_append(private, ".value", 16 | un_null_list(lapply(prms, "[[", "value"))) 17 | env_append(private, ".tags", 18 | un_null_list(lapply(prms, "[[", "tags"))) 19 | private$.isupports <- invert_names(private$.supports) 20 | } 21 | } else { 22 | stop("At least one parameter must be added.") 23 | } 24 | 25 | invisible(self) 26 | } 27 | 28 | .ParameterSet__add_check <- function(self, private, fun, ids, tags) { # nolint 29 | if (is.null(self$checks)) { 30 | checks <- data.table(ids = list(), tags = list(), fun = list()) 31 | } else { 32 | checks <- self$checks 33 | } 34 | 35 | if (is.null(ids) && is.null(tags)) { 36 | stop("At least one of 'ids' and 'tags' must be non-NULL.") 37 | } 38 | 39 | checkmate::assert_subset(ids, unique(c(self$ids, unprefix(self$ids)))) 40 | checkmate::assert_subset(tags, unlist(self$tags)) 41 | 42 | checkmate::assert_function(fun, "x", TRUE) 43 | if (!checkmate::test_logical(fun(self$values, self), len = 1)) { 44 | stop("'fun' should evaluate to a scalar logical.") 45 | } 46 | 47 | new_checks <- rbind(checks, 48 | data.table::data.table(ids = list(ids), 49 | tags = list(tags), 50 | fun = list(body(fun)))) 51 | 52 | .check_custom(self, self$values, new_checks, NULL, TRUE) 53 | 54 | private$.checks <- new_checks 55 | 56 | invisible(self) 57 | } --------------------------------------------------------------------------------