├── .Rbuildignore ├── .gitignore ├── .travis.yml ├── DESCRIPTION ├── LICENSE ├── Makefile ├── NAMESPACE ├── R ├── RcppR6_generate.R ├── RcppR6_read.R ├── RcppR6_validate.R ├── RcppR6_write.R ├── api.R ├── check.R ├── cpp_templates.R ├── mangle.R ├── utils.R ├── utils_assert.R └── utils_install.R ├── README.md ├── inst ├── Makefile ├── Makevars ├── doc │ ├── examples.html │ ├── introduction.html │ └── templates.html ├── examples │ ├── examples │ │ ├── .gitignore │ │ ├── DESCRIPTION │ │ ├── NAMESPACE │ │ ├── inst │ │ │ ├── RcppR6.yml │ │ │ ├── empty.yml │ │ │ ├── include │ │ │ │ ├── examples.h │ │ │ │ └── examples │ │ │ │ │ ├── empty.hpp │ │ │ │ │ ├── stack.hpp │ │ │ │ │ └── uniform.hpp │ │ │ ├── stack.yml │ │ │ └── uniform.yml │ │ └── tests │ │ │ ├── testthat.R │ │ │ └── testthat │ │ │ ├── test-simple.R │ │ │ ├── test-stack.R │ │ │ └── test-uniform.R │ ├── introduction │ │ ├── DESCRIPTION │ │ ├── NAMESPACE │ │ ├── inst │ │ │ ├── RcppR6_classes.yml │ │ │ └── include │ │ │ │ └── introduction.h │ │ └── tests │ │ │ ├── testthat.R │ │ │ └── testthat │ │ │ └── test-circle.R │ ├── list │ │ ├── DESCRIPTION │ │ ├── NAMESPACE │ │ ├── inst │ │ │ ├── RcppR6_classes.yml │ │ │ └── include │ │ │ │ ├── list.h │ │ │ │ └── list │ │ │ │ ├── mystruct.hpp │ │ │ │ ├── positive.hpp │ │ │ │ ├── triple1.hpp │ │ │ │ └── validated.hpp │ │ ├── src │ │ │ ├── test.cpp │ │ │ └── validated.cpp │ │ └── tests │ │ │ ├── testthat.R │ │ │ └── testthat │ │ │ ├── test-mystruct.R │ │ │ ├── test-positive.R │ │ │ ├── test-triple1.R │ │ │ └── test-validated.R │ └── templates │ │ ├── DESCRIPTION │ │ ├── inst │ │ ├── RcppR6_classes.yml │ │ ├── RcppR6_functions.yml │ │ └── include │ │ │ ├── templates.h │ │ │ └── templates │ │ │ ├── pair1.hpp │ │ │ └── pair1_functions.hpp │ │ └── tests │ │ ├── testthat.R │ │ └── testthat │ │ ├── test-pair1.R │ │ └── test-pair2.R ├── templates │ ├── R6_generator.whisker │ ├── R6_generator_generic.whisker │ ├── RcppR6.R_header.whisker │ ├── RcppR6.cpp_header.whisker │ ├── RcppR6_post.hpp.whisker │ ├── RcppR6_pre.hpp.whisker │ ├── RcppR6_support.R.whisker │ ├── RcppR6_support.hpp.whisker │ ├── RcppR6_traits.whisker │ ├── active_cpp.whisker │ ├── active_r.whisker │ ├── constructor_cpp.whisker │ ├── constructor_list_cpp.whisker │ ├── constructor_r.whisker │ ├── function_concrete.whisker │ ├── function_generic_explicit.whisker │ ├── function_generic_implicit.whisker │ ├── list_generator.whisker │ ├── method_cpp.whisker │ ├── method_r.whisker │ ├── package_include.h.whisker │ ├── rcpp_definitions.whisker │ ├── rcpp_list_definitions.whisker │ └── rcpp_prototypes.whisker └── vignette_common.R ├── man ├── RcppR6.Rd └── check.Rd ├── tests ├── testthat.R └── testthat │ ├── Makefile │ ├── helper-RcppR6.R │ ├── test-README.R │ ├── test-examples.R │ ├── test-list.R │ └── test-templates.R └── vignettes ├── examples.Rmd ├── introduction.Rmd ├── src ├── examples.R ├── introduction.R └── templates.R └── templates.Rmd /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ## Exclude files in sub-packages. This really should work, but does 2 | ## not. 3 | ^.*\\.so$ 4 | ^.*\\.o$ 5 | 6 | tests/testthat/testExamples/.Rbuildignore 7 | ^\.travis\.yml$ 8 | 9 | Makefile 10 | ignore/ 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | inst/doc 2 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Sample .travis.yml for R projects from https://github.com/craigcitro/r-travis 2 | 3 | language: c 4 | 5 | before_install: 6 | - curl -OL http://raw.github.com/craigcitro/r-travis/master/scripts/travis-tool.sh 7 | - chmod 755 ./travis-tool.sh 8 | - ./travis-tool.sh bootstrap 9 | 10 | install: 11 | - ./travis-tool.sh install_deps 12 | - ./travis-tool.sh install_github wch/R6 13 | 14 | script: ./travis-tool.sh run_tests 15 | 16 | after_failure: 17 | - ./travis-tool.sh dump_logs 18 | 19 | notifications: 20 | email: 21 | on_success: change 22 | on_failure: change 23 | slack: bdkd:hY2eBCaH3bbsvNwlWwOfFdfr 24 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: RcppR6 2 | Title: Code-generation Wrapping C++ Classes as R6 Classes 3 | Version: 0.2.004 4 | Authors@R: "Rich FitzJohn [aut, cre]" 5 | Description: Experiments! This is all a work in progress. See the 6 | README on the github page, at least for now. 7 | Depends: 8 | R (>= 3.1.0) 9 | License: BSD_2_clause + file LICENSE 10 | Imports: 11 | whisker, 12 | yaml, 13 | digest, 14 | Rcpp 15 | Suggests: 16 | R6 (>= 2.0.0), 17 | testthat, 18 | devtools, 19 | knitr 20 | VignetteBuilder: knitr 21 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2014 2 | COPYRIGHT HOLDER: Richard G. FitzJohn 3 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PACKAGE := $(shell grep '^Package:' DESCRIPTION | sed -E 's/^Package:[[:space:]]+//') 2 | RSCRIPT = Rscript --no-init-file 3 | 4 | all: 5 | 6 | install: 7 | R CMD INSTALL . 8 | 9 | clean: 10 | make -C src clean 11 | 12 | build: 13 | R CMD build . 14 | 15 | check: cleanup build 16 | R CMD check --no-manual `ls -1tr ${PACKAGE}*gz | tail -n1` 17 | @rm -f `ls -1tr ${PACKAGE}*gz | tail -n1` 18 | @rm -rf ${PACKAGE}.Rcheck 19 | 20 | roxygen: 21 | @mkdir -p man 22 | ${RSCRIPT} -e "library(methods); devtools::document()" 23 | 24 | test: 25 | ${RSCRIPT} -e 'library(methods); devtools::test()' 26 | 27 | cleanup: 28 | rm -f `find inst -name '*.o' -or -name '*.so'` 29 | 30 | vignettes/introduction.Rmd: vignettes/src/introduction.R 31 | ${RSCRIPT} -e 'library(sowsear); sowsear("$<", output="$@")' 32 | vignettes/examples.Rmd: vignettes/src/examples.R 33 | ${RSCRIPT} -e 'library(sowsear); sowsear("$<", output="$@")' 34 | vignettes/templates.Rmd: vignettes/src/templates.R 35 | ${RSCRIPT} -e 'library(sowsear); sowsear("$<", output="$@")' 36 | 37 | vignettes: vignettes/introduction.Rmd vignettes/examples.Rmd vignettes/templates.Rmd 38 | ${RSCRIPT} -e 'library(methods); devtools::build_vignettes()' 39 | 40 | .PHONY: all install clean build check roxygen test vignettes 41 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2 (4.1.1): do not edit by hand 2 | 3 | export(RcppR6) 4 | export(check) 5 | export(install) 6 | -------------------------------------------------------------------------------- /R/RcppR6_generate.R: -------------------------------------------------------------------------------- 1 | ## This bit is tricky because it *must* be recursive; we're going to 2 | ## trigger writing in deeper and deeper parts of the tree. For each 3 | ## level, we want to generate bits of template information that go in 4 | ## different places. 5 | RcppR6_generate <- function(dat) { 6 | info <- RcppR6_package_info(dat$path) 7 | info$hash <- dat$hash 8 | 9 | dat_c <- lapply(dat$classes, RcppR6_generate_class, info) 10 | dat_f <- lapply(dat$functions, RcppR6_generate_function, info) 11 | 12 | collect <- function(name, dat, required=TRUE, collapse="\n") { 13 | if (required) { 14 | str <- vcapply(dat, "[[", name) 15 | } else { 16 | str <- unlist(lapply(dat, "[[", name)) 17 | } 18 | paste(str, collapse=collapse) 19 | } 20 | 21 | info$forward_declaration <- collect("forward_declaration", dat_c, FALSE) 22 | info$rcpp_prototypes <- collect("rcpp_prototype", dat_c) 23 | info$rcpp_definitions <- collect("rcpp_definition", dat_c) 24 | info$RcppR6_traits <- collect("RcppR6_traits", dat_c) 25 | 26 | wr_data <- list(RcppR6=info$RcppR6, package=info) 27 | 28 | str_r_header <- wr(info$templates$RcppR6.R_header, wr_data) 29 | if (any(vlapply(dat$classes, "[[", "is_templated"))) { 30 | str_r_header <- paste(str_r_header, 31 | info$templates$RcppR6_support.R, 32 | sep="\n\n") 33 | } 34 | 35 | str_cpp_header <- wr(info$templates$RcppR6.cpp_header, wr_data) 36 | str_RcppR6.R <- paste(str_r_header, 37 | collect("r", dat_c, collapse="\n\n"), 38 | if (length(dat_f) > 0) 39 | collect("r", dat_f, collapse="\n\n"), 40 | sep="\n\n") 41 | str_RcppR6.cpp <- paste(str_cpp_header, 42 | collect("cpp", dat_c, collapse="\n\n"), 43 | if (length(dat_f) > 0) 44 | collect("cpp", dat_f, collapse="\n\n"), 45 | sep="\n\n") 46 | 47 | ## Coming out, *all* we want is the generated code I think, rather 48 | ## than the intermediates. It'd be pretty easy to also return the 49 | ## intermediates, but lets not for now as that leaves us free to 50 | ## rejig how those internals are kept. 51 | ## 52 | ## The package info bits are also required as they have the filename 53 | ## locations; they could be easily regenerated, alternatively. 54 | contents <- list( 55 | RcppR6.R = str_RcppR6.R, 56 | RcppR6.cpp = str_RcppR6.cpp, 57 | RcppR6_pre.hpp = wr(info$templates$RcppR6_pre.hpp, wr_data), 58 | RcppR6_post.hpp = wr(info$templates$RcppR6_post.hpp, wr_data), 59 | RcppR6_support.hpp = wr(info$templates$RcppR6_support.hpp, wr_data)) 60 | list(package=info, contents=contents) 61 | } 62 | 63 | ## TODO: lots of intermediate bits through here that can be simplified 64 | ## together; but the functions are pure now so that makes it easier to 65 | ## think about. 66 | ## 67 | ## The res / info / wr_data thing is very poorly thought though and 68 | ## may change completely soon. Also, need to work out what the 69 | ## minimum amount of data to be returned is. 70 | RcppR6_package_info <- function(path) { 71 | package_name <- package_name(path) 72 | paths <- 73 | list(root = path, 74 | inst = file.path(path, "inst"), 75 | include = file.path(path, "inst/include"), 76 | include_pkg = file.path(path, "inst/include", package_name), 77 | r = file.path(path, "R"), 78 | src = file.path(path, "src")) 79 | files <- list( 80 | RcppR6.R = file.path(paths$r, "RcppR6.R"), 81 | RcppR6.cpp = file.path(paths$src, "RcppR6.cpp"), 82 | RcppR6_pre.hpp = file.path(paths$include_pkg, "RcppR6_pre.hpp"), 83 | RcppR6_post.hpp = file.path(paths$include_pkg, "RcppR6_post.hpp"), 84 | RcppR6_support.hpp = file.path(paths$include_pkg, "RcppR6_support.hpp"), 85 | package_include = file.path(paths$include, sprintf("%s.h", package_name))) 86 | 87 | ret <- list() 88 | ret$name <- package_name 89 | ret$NAME <- toupper(package_name) 90 | ret$paths <- paths 91 | ret$files <- files 92 | ret$templates <- RcppR6_read_templates() 93 | ret$RcppR6 <- RcppR6_RcppR6_info() 94 | ret 95 | } 96 | 97 | RcppR6_RcppR6_info <- function() { 98 | list(input_name="obj_", 99 | type_name="type", 100 | ## These should be constant, but would vary if using RC backend 101 | r_self_name="self", 102 | r_value_name="value", 103 | R6_ptr_name=".ptr", 104 | R6_generator_prefix=mangle_R6_generator(""), 105 | version=as.character(packageVersion(.packageName))) 106 | } 107 | 108 | RcppR6_generate_class <- function(dat, info) { 109 | if (dat$type == "class_ref") { 110 | RcppR6_generate_class_ref(dat, info) 111 | } else { 112 | RcppR6_generate_class_list(dat, info) 113 | } 114 | } 115 | 116 | ## Here, consider farming out the templated types entirely. 117 | RcppR6_generate_class_ref <- function(dat, info) { 118 | ret <- list() 119 | ret$name_r <- dat$name_r 120 | ret$name_cpp <- dat$name_cpp 121 | ret$name_safe <- dat$name_safe 122 | ret$is_templated <- dat$is_templated 123 | ## This is only non-NULL for templated classes 124 | if (!is.null(dat$inherits)) { 125 | ret$inherits <- mangle_R6_generator(dat$inherits) 126 | } 127 | 128 | ret$input_type <- mangle_input(info$name, dat$name_cpp) 129 | ret$R6_generator <- mangle_R6_generator(dat$name_safe) 130 | ret$forward_declaration <- RcppR6_generate_forward_declaration(dat) 131 | 132 | if (ret$is_templated) { 133 | ## Need to push the template information in here... 134 | ret$templates <- dat$templates 135 | res_constructor <- RcppR6_generate_constructor(dat$constructor, info, ret) 136 | 137 | concrete <- lapply(ret$templates$concrete, function(x) 138 | RcppR6_generate_class_ref(x$class, info)) 139 | 140 | keep <- c("r", "cpp", 141 | "RcppR6_traits", 142 | "rcpp_prototype", 143 | "rcpp_definition") 144 | ret[keep] <- lapply(keep, function(x) 145 | paste(vcapply(concrete, "[[", x), collapse="\n\n")) 146 | ret$r <- paste(res_constructor$r, ret$r, sep="\n\n") 147 | } else { 148 | res_constructor <- RcppR6_generate_constructor(dat$constructor, info, ret) 149 | res_methods <- lapply(dat$methods, RcppR6_generate_method, info, ret) 150 | res_active <- lapply(dat$active, RcppR6_generate_active, info, ret) 151 | 152 | join_r <- function(x, pre) { 153 | if (length(x) > 0L) { 154 | paste0(pre, indent(paste(x, collapse=",\n"), 6L)) 155 | } 156 | } 157 | join_cpp <- function(x) { 158 | if (length(x) > 0L) { 159 | paste(x, collapse="\n") 160 | } 161 | } 162 | 163 | ret$methods_r <- join_r(vcapply(res_methods, "[[", "r"), ",\n") 164 | ret$active_r <- join_r(vcapply(res_active, "[[", "r"), "\n") 165 | 166 | ret$constructor_cpp <- res_constructor$cpp 167 | ret$methods_cpp <- join_cpp(vcapply(res_methods, "[[", "cpp")) 168 | ret$active_cpp <- join_cpp(vcapply(res_active, "[[", "cpp")) 169 | 170 | wr_data <- list(class=ret, package=info, RcppR6=info$RcppR6) 171 | ret$class_r <- wr(info$templates$R6_generator, wr_data) 172 | 173 | ## NOTE: using paste(c(...), collapse=.) rather than paste(..., sep=.) 174 | ## because it filters NULL values 175 | ret$r <- paste(c(res_constructor$r, 176 | ret$class_r), collapse="\n") 177 | ret$cpp <- paste(c(ret$constructor_cpp, 178 | ret$methods_cpp, 179 | ret$active_cpp), collapse="\n") 180 | 181 | ## TODO: Rename 182 | ## - rcpp_prototypes -> rcpp_prototype 183 | ## - rcpp_definitions -> rcpp_definition 184 | ret$rcpp_prototype <- wr(info$templates$rcpp_prototypes, wr_data) 185 | ret$rcpp_definition <- wr(info$templates$rcpp_definitions, wr_data) 186 | ret$RcppR6_traits <- wr(info$templates$RcppR6_traits, wr_data) 187 | } 188 | ret 189 | } 190 | 191 | RcppR6_generate_constructor <- function(dat, info, parent) { 192 | ret <- list() 193 | ret$roxygen <- RcppR6_generate_roxygen(dat$roxygen) 194 | ret$args <- RcppR6_generate_args(dat$args, info) 195 | 196 | if (parent$is_templated) { 197 | ret$r <- RcppR6_generate_constructor_template_switch(ret, info, parent) 198 | } else { 199 | ret$name_cpp <- dat$name_cpp 200 | ret$name_safe <- mangle_constructor(parent$name_safe) 201 | ret$return_type <- parent$name_cpp 202 | wr_data <- list(constructor=ret, class=parent) 203 | ## TODO: Don't always use `` around the name; do that only if 204 | ## parse/deparse requires it (might be slower to check). 205 | ret$r <- wr(info$templates$constructor_r, wr_data) 206 | ret$cpp <- wr(info$templates$constructor_cpp, wr_data) 207 | } 208 | 209 | ret 210 | } 211 | 212 | RcppR6_generate_method <- function(dat, info, parent) { 213 | ret <- list() 214 | 215 | ret$name_r <- dat$name_r 216 | ret$name_cpp <- dat$name_cpp 217 | ret$name_safe <- mangle_method(parent$name_safe, dat$name_safe) 218 | 219 | ret$return_type <- dat$return_type 220 | ret$return_statement <- if (dat$return_type == "void") "" else "return " 221 | ret$is_member <- dat$access == "member" 222 | ret$is_function <- dat$access == "function" 223 | 224 | ret$args <- RcppR6_generate_args(dat$args, info) 225 | 226 | wr_data <- list(RcppR6=info$RcppR6, method=ret) 227 | ret$r <- wr(info$templates$method_r, wr_data) 228 | ret$cpp <- drop_blank(wr(info$templates$method_cpp, wr_data)) 229 | 230 | ret 231 | } 232 | 233 | RcppR6_generate_active <- function(dat, info, parent) { 234 | ret <- list() 235 | ret$name_r <- dat$name_r 236 | ret$is_readonly <- dat$readonly # NOTE change of name here 237 | 238 | ret$name_safe_get <- mangle_active(parent$name_safe, dat$name_safe, "get") 239 | if (dat$access == "field") { 240 | ret$name_cpp <- dat[["name_cpp"]] 241 | } else { 242 | ret$name_cpp_get <- dat[["name_cpp"]] 243 | } 244 | if (!dat$readonly) { 245 | ret$name_safe_set <- mangle_active(parent$name_safe, dat$name_safe, "set") 246 | ret$name_cpp_set <- dat[["name_cpp_set"]] 247 | } 248 | ret$input_type <- mangle_input(info$name, parent$name_cpp) 249 | ret$class_name_r <- parent$name_r 250 | ret$return_type <- dat$type 251 | ret$is_field <- dat$access == "field" 252 | ret$is_member <- dat$access == "member" 253 | ret$is_function <- dat$access == "function" 254 | 255 | wr_data <- list(RcppR6=info$RcppR6, active=ret) 256 | ret$r <- drop_blank(wr(info$templates$active_r, wr_data)) 257 | ret$cpp <- drop_blank(wr(info$templates$active_cpp, wr_data)) 258 | 259 | ret 260 | } 261 | 262 | RcppR6_generate_args <- function(dat, info) { 263 | RcppR6 <- info$RcppR6 264 | is_constructor <- dat$parent_type == "constructor" 265 | is_member <- dat$parent_type == "member" 266 | is_function <- dat$parent_type == "function" 267 | is_free_function <- dat$parent_type == "free_function" 268 | 269 | needs_object <- !(is_constructor || is_free_function) 270 | 271 | ret <- list() 272 | ## R: 273 | if (is.null(dat$defaults)) { 274 | ret$defn_r <- collapse(dat$names) 275 | } else { 276 | defn_r <- dat$names 277 | i <- !is.na(dat$defaults) 278 | defn_r[i] <- sprintf("%s=%s", dat$names[i], dat$defaults[i]) 279 | ret$defn_r <- collapse(defn_r) 280 | } 281 | 282 | ret$body_r <- collapse(c(if (needs_object) RcppR6$r_self_name, dat$names)) 283 | 284 | ## C++ details are harder: 285 | if (needs_object) { 286 | input_cpp <- mangle_input(info$name, dat$parent_class_name_cpp) 287 | types_cpp <- c(input_cpp, dat$types) 288 | names_cpp <- c(RcppR6$input_name, dat$names) 289 | body_cpp_prefix <- if (!is_member) paste0("*", RcppR6$input_name) 290 | } else { 291 | types_cpp <- dat$types 292 | names_cpp <- dat$names 293 | body_cpp_prefix <- NULL 294 | } 295 | ret$defn_cpp <- paste(types_cpp, names_cpp, collapse=", ") 296 | ret$body_cpp <- collapse(c(body_cpp_prefix, dat$names)) 297 | 298 | ret 299 | } 300 | 301 | RcppR6_generate_roxygen <- function(str) { 302 | if (length(str) > 0) { 303 | paste(paste0("##' ", strsplit(str, "\n", fixed=TRUE)[[1]]), 304 | collapse="\n") 305 | } else { 306 | "" 307 | } 308 | } 309 | 310 | RcppR6_generate_forward_declaration <- function(x) { 311 | if (x$forward_declare) { 312 | info <- guess_namespace(x$name_cpp) 313 | ns <- strsplit(info$namespace, "::", fixed=TRUE)[[1]] 314 | paste0(paste(sprintf("namespace %s { ", ns), collapse=""), 315 | sprintf("%s %s;", x$forward_declare_type, info$name), 316 | paste(rep(" }", length(ns)), collapse="")) 317 | } else { 318 | character(0) 319 | } 320 | } 321 | 322 | RcppR6_generate_roxygen <- function(str) { 323 | if (length(str) > 0) { 324 | paste(paste0("##' ", strsplit(str, "\n", fixed=TRUE)[[1]]), 325 | collapse="\n") 326 | } else { 327 | "" 328 | } 329 | } 330 | 331 | RcppR6_generate_class_list <- function(dat, info) { 332 | ret <- list() 333 | ret$name_r <- dat$name_r 334 | ret$name_cpp <- dat$name_cpp 335 | ret$name_safe <- dat$name_safe 336 | ret$input_type <- mangle_input(info$name, dat$name_cpp) 337 | ret$forward_declaration <- RcppR6_generate_forward_declaration(dat) 338 | 339 | ret$is_templated <- dat$is_templated 340 | ## This is only non-NULL for templated classes 341 | if (!is.null(dat$inherits)) { 342 | ret$inherits <- dat$inherits 343 | } 344 | 345 | if (ret$is_templated) { 346 | ret$templates <- dat$templates 347 | 348 | concrete <- lapply(ret$templates$concrete, function(x) 349 | RcppR6_generate_class_list(x$class, info)) 350 | 351 | keep <- c("r", "cpp", 352 | "RcppR6_traits", 353 | "rcpp_prototype", 354 | "rcpp_definition") 355 | ret[keep] <- lapply(keep, function(x) 356 | paste(vcapply(concrete, "[[", x), collapse="\n\n")) 357 | 358 | ret$r <- paste(RcppR6_generate_constructor_template_switch(dat, info, dat), 359 | ret$r, sep="\n\n") 360 | } else { 361 | ret$validator <- RcppR6_generate_validator(dat$validator, dat) 362 | ret$constructor <- list(name_cpp=mangle_constructor(dat$name_safe), 363 | name_r=dat$name_r, 364 | roxygen=RcppR6_generate_roxygen(dat$roxygen)) 365 | ret$fields <- whisker::iteratelist(dat$list, 366 | name="field_name", 367 | value="field_type") 368 | 369 | wr_data <- list(class=ret, package=info, RcppR6=info$RcppR6) 370 | 371 | ret$r <- drop_blank(wr(info$templates$list_generator, wr_data)) 372 | ret$cpp <- drop_blank(wr(info$templates$constructor_list_cpp, wr_data)) 373 | 374 | ret$rcpp_prototype <- wr(info$templates$rcpp_prototypes, wr_data) 375 | ret$rcpp_definition <- 376 | drop_blank(wr(info$templates$rcpp_list_definitions, wr_data)) 377 | ret$RcppR6_traits <- wr(info$templates$RcppR6_traits, wr_data) 378 | } 379 | 380 | ret 381 | } 382 | 383 | RcppR6_generate_constructor_template_switch <- function(dat, info, parent) { 384 | ret <- list() 385 | ret$roxygen <- dat$roxygen 386 | ret$types <- collapse(parent$templates$parameters) 387 | 388 | ## Valid template types: 389 | valid <- sapply(parent$templates$concrete, function(x) 390 | dput_to_character(unname(x$parameters_r))) 391 | names(valid) <- vcapply(parent$templates$concrete, "[[", "name_r") 392 | ret$valid_r_repr <- 393 | sprintf("list(%s)", collapse(sprintf('"%s"=%s', names(valid), valid))) 394 | 395 | ## Don't use the strings here: we want the actual functions: 396 | ## TODO: Do this with switch() perhaps? 397 | ret$constructors_r_repr <- 398 | sprintf("list(%s)", collapse(sprintf('"%s"=`%s`', 399 | names(valid), names(valid)))) 400 | wr_data <- list(constructor=ret, class=parent) 401 | drop_blank(wr(info$templates$R6_generator_generic, wr_data)) 402 | } 403 | 404 | RcppR6_generate_validator <- function(dat, parent) { 405 | ret <- dat 406 | if (!is.null(dat)) { 407 | ret$is_member <- dat$access == "member" 408 | ret$is_function <- dat$access == "function" 409 | } 410 | ret 411 | } 412 | 413 | RcppR6_generate_function <- function(dat, info) { 414 | ret <- list() 415 | ret$r <- RcppR6_generate_function_template_switch(info, dat) 416 | cpp <- vcapply(dat$concrete, RcppR6_generate_function_concrete, info, dat) 417 | ret$cpp <- paste(cpp, collapse="\n") 418 | ret 419 | } 420 | 421 | ## This is going to share some common code with the class version too. 422 | RcppR6_generate_function_template_switch <- function(info, parent) { 423 | ret <- list() 424 | 425 | ret$name_r <- parent$name_r 426 | 427 | ret$types <- collapse(parent$templates$parameters) 428 | 429 | infer_type <- parent$templates$infer_type 430 | concrete <- parent$templates$class$templates$concrete 431 | 432 | if (infer_type == "explicit") { 433 | ## Valid template types: 434 | valid <- sapply(concrete, function(x) 435 | dput_to_character(unname(x$parameters_r))) 436 | names(valid) <- vcapply(concrete, "[[", "name_r") 437 | ret$valid_r_repr <- 438 | sprintf("list(%s)", collapse(sprintf('"%s"=%s', names(valid), valid))) 439 | 440 | ## Don't use the strings here: we want the actual functions: 441 | ## TODO: Do this with switch() perhaps? (See also 442 | ## RcppR6_generate_constructor_template_switch) 443 | name_safe <- vcapply(parent$concrete, "[[", "name_safe") 444 | ret$functions_r_repr <- 445 | sprintf("list(%s)", collapse(sprintf('"%s"=`%s`', 446 | names(valid), name_safe))) 447 | 448 | wr_data <- list("function"=ret) 449 | drop_blank(wr(info$templates$function_generic_explicit, wr_data)) 450 | } else if (infer_type == "implicit") { 451 | ret$args <- RcppR6_generate_args(parent$args, info) 452 | ret$arg1_name <- parent$args$names[[1]] 453 | 454 | if (parent$templates$infer_type_arg1_raw_parameter) { 455 | ## TODO: This *requires* that the classes that are passed 456 | ## through to R are *exactly* as written. So double/real must 457 | ## be numeric, int must be integer, etc. That might be a bit 458 | ## limiting, so it might be useful to allow a mapping function 459 | ## here too. 460 | types_r <- vcapply(concrete, "[[", "parameters_r") 461 | } else { 462 | ## TODO: This is not actually good enough; we need to make sure 463 | ## that the templating is across the same set of concrete types 464 | ## (i.e., that subsituting T in both infer_type_arg1_type and 465 | ## the underlying class type are valid). For now I'll ignore 466 | ## this. 467 | type <- parent$templates$infer_type_arg1_type 468 | types_r <- vcapply(type$templates$concrete, "[[", "name_r") 469 | } 470 | name_safe <- vcapply(parent$concrete, "[[", "name_safe") 471 | ret$switch_body <- 472 | indent(collapse(sprintf('"%s"=`%s`', types_r, name_safe), ",\n"), 9) 473 | wr_data <- list("function"=ret) 474 | drop_blank(wr(info$templates$function_generic_implicit, wr_data)) 475 | } else { 476 | stop("Something is not implemented") 477 | } 478 | } 479 | 480 | RcppR6_generate_function_concrete <- function(dat, info, parent) { 481 | ret <- list() 482 | ret$name_safe <- dat$name_safe 483 | ret$name_cpp <- dat$name_cpp 484 | ret$return_type <- dat$return_type 485 | ret$return_statement <- if (dat$return_type == "void") "" else "return " 486 | ret$args <- RcppR6_generate_args(dat$args, info) 487 | wr_data <- list("function"=ret) 488 | wr(info$templates$function_concrete, wr_data) 489 | } 490 | -------------------------------------------------------------------------------- /R/RcppR6_read.R: -------------------------------------------------------------------------------- 1 | ## First pass: read the files. 2 | ## 3 | ## For now, the assumption is that files are in /inst but that 4 | ## could change. 5 | RcppR6_read <- function(path, verbose=TRUE) { 6 | config <- RcppR6_read_config(path) 7 | filename_classes <- file.path(path, config$classes) 8 | filename_functions <- file.path(path, config$functions) 9 | classes <- join_lists(lapply(filename_classes, RcppR6_read_classes, 10 | path, verbose)) 11 | functions <- join_lists(lapply(filename_functions, RcppR6_read_functions, 12 | path, verbose)) 13 | list(path=path, 14 | classes=classes, 15 | functions=functions, 16 | hash=digest::digest(list(classes, functions))) 17 | } 18 | 19 | RcppR6_read_config <- function(path) { 20 | filename <- file.path(path, "inst/RcppR6.yml") 21 | if (file.exists(filename)) { 22 | dat <- yaml_read(filename) 23 | if (is.null(dat$functions)) { 24 | dat$functions <- character(0) 25 | } 26 | } else { 27 | dat <- RcppR6_config_default(path) 28 | } 29 | warn_unknown("RcppR6", dat, c("classes", "functions")) 30 | assert_character(dat$classes) 31 | assert_character(dat$functions) 32 | if (length(dat$classes) == 0) { 33 | stop("Need at least one set of classes") 34 | } 35 | dat 36 | } 37 | 38 | RcppR6_read_classes <- function(filename, base, verbose) { 39 | if (verbose) { 40 | message("Reading classes from ", drop_leading_path(filename, base)) 41 | } 42 | assert_file_exists(filename) 43 | yaml_read(filename) 44 | } 45 | 46 | RcppR6_read_functions <- function(filename, base, verbose) { 47 | if (verbose) { 48 | message("Reading functions from ", drop_leading_path(filename, base)) 49 | } 50 | assert_file_exists(filename) 51 | yaml_read(filename) 52 | } 53 | 54 | 55 | RcppR6_config_default <- function(path) { 56 | functions <- "inst/RcppR6_functions.yml" 57 | if (!file.exists(file.path(path, functions))) { 58 | functions <- character(0) 59 | } 60 | list(classes="inst/RcppR6_classes.yml", 61 | functions=functions) 62 | } 63 | 64 | ## Read all templates. This makes things slightly simpler later. 65 | RcppR6_read_templates <- function() { 66 | path <- RcppR6_file("templates") 67 | files <- dir(path, pattern=glob2rx("*.whisker")) 68 | dat <- lapply(file.path(path, files), read_file) 69 | names(dat) <- sub("\\.whisker$", "", files) 70 | dat 71 | } 72 | 73 | ## Extract a file from the RcppR6 (this!) package. Just sets some 74 | ## defaults to \code{\link{system.file}} 75 | RcppR6_file <- function(...) { 76 | system.file(..., package=.packageName, mustWork=TRUE) 77 | } 78 | -------------------------------------------------------------------------------- /R/RcppR6_validate.R: -------------------------------------------------------------------------------- 1 | ## TODO: The thing that is needed here is the backtrace that I 2 | ## generated last time. That was pretty useful. 3 | RcppR6_validate <- function(dat) { 4 | if (length(dat$classes) > 0) { 5 | assert_list(dat$classes) 6 | assert_named(dat$classes) 7 | dat$classes <- lapply(seq_along(dat$classes), function(i) 8 | RcppR6_validate_class(dat$classes[i])) 9 | dat$functions <- lapply(seq_along(dat$functions), function(i) 10 | RcppR6_validate_function(dat$functions[i], dat$classes)) 11 | } 12 | 13 | dat 14 | } 15 | 16 | RcppR6_validate_class <- function(defn) { 17 | if ("list" %in% names(defn[[1]])) { 18 | RcppR6_validate_class_list(defn) 19 | } else { 20 | RcppR6_validate_class_ref(defn) 21 | } 22 | } 23 | 24 | RcppR6_validate_class_ref <- function(defn) { 25 | valid <- c("name_cpp", "forward_declare", 26 | "constructor", "methods", "active", 27 | "templates") 28 | ret <- RcppR6_validate_common(defn, valid) 29 | defn <- ret$defn 30 | ret$defn <- NULL 31 | 32 | ret <- modifyList(ret, 33 | RcppR6_validate_forward_declare(defn$forward_declare)) 34 | 35 | ret$constructor <- RcppR6_validate_constructor(defn$constructor, ret) 36 | ret$methods <- RcppR6_validate_method_list(defn$methods, ret) 37 | ret$active <- RcppR6_validate_active_list(defn$active, ret) 38 | ret$templates <- RcppR6_validate_templates(defn$templates, ret) 39 | 40 | ret$is_templated <- !is.null(ret$templates) 41 | ret$type <- "class_ref" 42 | 43 | ret 44 | } 45 | 46 | ## This checks that the yaml chunk looks reasonable and checks names. 47 | ## It's used by: 48 | ## class 49 | ## constructor 50 | ## method 51 | ## active 52 | RcppR6_validate_common <- function(defn, valid=NULL) { 53 | assert_scalar_list(defn) 54 | assert_named(defn) 55 | ret <- list() 56 | ret$name_r <- names(defn) 57 | ret$defn <- defn[[1]] 58 | if (!is.null(valid)) { 59 | warn_unknown(ret$name_r, ret$defn, valid) 60 | } 61 | ret$name_safe <- RcppR6_validate_name(ret$name_r) 62 | ## NOTE: Be careful about partial matching on name_cpp / name_cpp_set 63 | ret$name_cpp <- with_default(ret$defn[["name_cpp"]], ret$name_r) 64 | assert_scalar_character(ret$name_cpp) 65 | ret 66 | } 67 | 68 | ## TODO: all of these build the returned object piecewise; better to 69 | ## do that all at once. 70 | RcppR6_validate_constructor <- function(defn, parent) { 71 | if (!is.null(defn)) { 72 | assert_list(defn) 73 | assert_named(defn) 74 | } 75 | warn_unknown("constructor", defn, c("roxygen", "name_cpp", "args")) 76 | 77 | ret <- list() 78 | ret$name_cpp <- with_default(defn$name_cpp, parent$name_cpp) 79 | assert_scalar_character(ret$name_cpp) 80 | 81 | if (!is.null(defn$roxygen)) { 82 | ret$roxygen <- defn$roxygen 83 | assert_scalar_character(ret$roxygen) 84 | } 85 | 86 | ret$args <- RcppR6_validate_args(defn$args, ret, "constructor", parent) 87 | ret 88 | } 89 | 90 | RcppR6_validate_args <- function(defn, parent, parent_type, parent_class) { 91 | defn_args <- yaml_seq_map(defn) 92 | ret <- list() 93 | ret$names <- names(defn_args) 94 | 95 | contents <- vcapply(defn_args, first, USE.NAMES=FALSE) 96 | re_default <- "\\s*=\\s*" 97 | if (any(grepl(re_default, contents))) { 98 | info <- strsplit_first(contents, re_default) 99 | ret$types <- info[, 1] 100 | ret$defaults <- info[, 2] 101 | } else { 102 | ret$types <- contents 103 | ret$defaults <- NULL 104 | } 105 | 106 | ## These are both needed later on, in the templating stage. This 107 | ## might change. 108 | ## TODO: consider "function_type" rather than "parent_type"? 109 | ## or even "parent_function_type". Affects RcppR6_generate_args() 110 | ## 111 | ## NOTE: This refers to the C++ origin of the function more than the 112 | ## eventual R destination; free_function refers (for now at least) 113 | ## to something destined to be a freee function on the R side. Not 114 | ## pretty! 115 | ret$parent_type <- match_value(parent_type, 116 | c("constructor", "member", 117 | "function", "free_function")) 118 | ret$parent_class_name_cpp <- parent_class$name_cpp 119 | 120 | ret 121 | } 122 | 123 | RcppR6_validate_method_list <- function(defn, parent) { 124 | if (length(defn) > 0) { 125 | assert_list(defn) 126 | assert_named(defn) 127 | lapply(seq_along(defn), function(i) RcppR6_validate_method(defn[i], parent)) 128 | } 129 | } 130 | 131 | RcppR6_validate_active_list <- function(defn, parent) { 132 | if (length(defn) > 0) { 133 | assert_list(defn) 134 | assert_named(defn) 135 | lapply(seq_along(defn), function(i) RcppR6_validate_active(defn[i], parent)) 136 | } 137 | } 138 | 139 | RcppR6_validate_method <- function(defn, parent) { 140 | valid <- c("name_cpp", "return_type", "access", "args") 141 | ret <- RcppR6_validate_common(defn, valid) 142 | defn <- ret$defn 143 | ret$defn <- NULL 144 | 145 | ret$return_type <- defn$return_type 146 | assert_scalar_character(ret$return_type) 147 | 148 | access <- with_default(defn$access, "member") 149 | ret$access <- match_value(access, c("member", "function")) 150 | assert_scalar_character(ret$access) 151 | 152 | ret$args <- RcppR6_validate_args(defn$args, ret, ret$access, parent) 153 | ret 154 | } 155 | 156 | RcppR6_validate_active <- function(defn, parent) { 157 | valid <- c("name_cpp", "name_cpp_set", "type", "access", 158 | "readonly") 159 | ret <- RcppR6_validate_common(defn, valid) 160 | 161 | defn <- ret$defn 162 | ret$defn <- NULL 163 | 164 | ret$type <- defn$type 165 | assert_scalar_character(ret$type) 166 | 167 | ret$access <- match_value(defn$access, 168 | c("field", "member", "function")) 169 | assert_scalar_character(ret$access) 170 | 171 | if (ret$access == "field") { 172 | ret$readonly <- with_default(defn$readonly, FALSE) 173 | assert_scalar_logical(ret$readonly) 174 | if (!is.null(defn$name_cpp_set)) { 175 | stop('name_cpp_set may not be given when access is "field"') 176 | } 177 | } else { 178 | ret$name_cpp_set <- defn$name_cpp_set 179 | ret$readonly <- is.null(ret$name_cpp_set) 180 | if (!ret$readonly) { 181 | assert_scalar_character(ret$name_cpp_set) 182 | } 183 | } 184 | 185 | ret 186 | } 187 | 188 | RcppR6_validate_templates <- function(defn, parent) { 189 | if (length(defn) > 0) { 190 | ret <- list() 191 | warn_unknown("templates", defn, c("parameters", "concrete")) 192 | ret$parameters <- defn$parameters 193 | assert_character(ret$parameters) 194 | assert_nonempty(ret$parameters) 195 | if (any(grepl("[^[:alnum:]_.]", ret$parameters))) { # check for "T1, T2" 196 | stop("Parameters need to be given as a yaml list of valid identifiers") 197 | } 198 | 199 | ## Simplest solution of several possibilities: 200 | re <- sprintf("[[:space:]]*<%s>", 201 | paste(sprintf("[[:space:]]*%s[[:space:]]*", 202 | ret$parameters), collapse=",")) 203 | if (!grepl(re, parent$name_cpp)) { 204 | stop("name_cpp must be a templated type") 205 | } 206 | 207 | ret$concrete <- RcppR6_validate_concrete_list(defn$concrete, ret, parent) 208 | ret 209 | } 210 | } 211 | 212 | RcppR6_validate_concrete_list <- function(defn, parent, parent_class) { 213 | if (length(defn) > 0) { 214 | if (is.character(defn)) { 215 | defn <- as.list(defn) 216 | } 217 | assert_list(defn) 218 | ret <- lapply(seq_along(defn), function(i) 219 | RcppR6_validate_concrete(defn[i], parent, parent_class)) 220 | 221 | parameters_r <- lapply(ret, "[[", "parameters_r") 222 | if (any(duplicated(parameters_r))) { 223 | dups <- parameters_r[duplicated(parameters_r)] 224 | stop(sprintf("Duplicated parameter names in class %s: %s", 225 | parent_class$name_r, paste(dups, collapse=", "))) 226 | } 227 | ret 228 | } 229 | } 230 | 231 | RcppR6_validate_concrete <- function(defn, parent, parent_class) { 232 | ## TODO: This is required, but I don't remember why that is the case... 233 | defn <- defn[[1]] 234 | ## This allows '- int' to be treated as '- [int: int]' 235 | x <- unlist(yaml_seq_map(as.list(defn), named=FALSE)) 236 | ok <- (is.character(x) && !is.null(names(x)) && 237 | length(x) == length(parent$parameters)) 238 | if (!ok) { 239 | stop("Invalid concrete representation.\n\t", yaml::as.yaml(defn)) 240 | } 241 | 242 | ret <- list() 243 | ret$parameters_r <- setNames(names(x), parent$parameters) 244 | ret$parameters_cpp <- setNames(unname(x), parent$parameters) 245 | ret$parameters_safe <- RcppR6_validate_name(ret$parameters_r) 246 | ret$name_r <- mangle_template_type_r(parent_class$name_r, 247 | ret$parameters_r) 248 | ret$name_cpp <- cpp_template_rewrite_types(parent_class$name_cpp, ret) 249 | ret$name_safe <- mangle_template_type(parent_class$name_safe, 250 | ret$parameters_safe) 251 | 252 | ret$class <- cpp_template_rewrite_class(ret, parent, parent_class) 253 | ret 254 | } 255 | 256 | RcppR6_validate_class_list <- function(defn) { 257 | valid <- c("name_cpp", "forward_declare", "list", 258 | "templates", "roxygen", "validator") 259 | ret <- RcppR6_validate_common(defn, valid) 260 | defn <- ret$defn 261 | ret$defn <- NULL 262 | 263 | ## Check the actual list here, in self$list; basically all we need 264 | ## is a named list with no duplicate names, and every element of 265 | ## this is a character vector. Pretty easy! 266 | ret$list <- yaml_seq_map(defn$list) 267 | assert_named(ret$list) 268 | if (!all(vlapply(ret$list, is_scalar_character))) { 269 | stop("All elements of 'list' must be a scalar character") 270 | } 271 | 272 | if (!is.null(defn$roxygen)) { 273 | ret$roxygen <- defn$roxygen 274 | assert_scalar_character(ret$roxygen) 275 | } 276 | 277 | if (!is.null(defn$validator)) { 278 | ret$validator <- RcppR6_validate_validator(defn$validator, ret) 279 | } 280 | 281 | ret <- modifyList(ret, 282 | RcppR6_validate_forward_declare(defn$forward_declare)) 283 | 284 | ret$templates <- RcppR6_validate_templates(defn$templates, ret) 285 | ret$is_templated <- !is.null(ret$templates) 286 | 287 | ret$type <- "class_list" 288 | 289 | ret 290 | } 291 | 292 | RcppR6_validate_forward_declare <- function(defn) { 293 | ## Three major options: FALSE / TRUE / {class | struct} 294 | ret <- list(forward_declare=with_default(defn, FALSE)) 295 | if (isFALSE(ret$forward_declare)) { 296 | ret$forward_declare <- FALSE 297 | ret$forward_declare_type <- NULL 298 | } else if (isTRUE(ret$forward_declare)) { 299 | ret$forward_declare_type <- "class" 300 | } else { 301 | ret$forward_declare_type <- match_value(ret$forward_declare, 302 | c("class", "struct")) 303 | ret$forward_declare <- TRUE 304 | } 305 | ret 306 | } 307 | 308 | ## This might change to check on both R and C sides. 309 | ## Not checked: 310 | ## Can't start with a number 311 | ## If it starts with a period, second character must be a letter 312 | ## Can't be a reserved word (in either language) 313 | ## http://stackoverflow.com/questions/15285787/can-you-start-a-class-name-with-a-numeric-digit 314 | RcppR6_validate_name <- function(x) { 315 | x <- gsub(".", "_", x, fixed=TRUE) 316 | if (any(i <- grepl("[^[:alnum:]_]", x))) { 317 | stop("Name ", collapse(dQuote(x[i])), " does not look valid in R & C") 318 | } 319 | x 320 | } 321 | 322 | RcppR6_validate_validator <- function(defn, parent) { 323 | ret <- list() 324 | ret$name_cpp <- defn$name_cpp 325 | ret$name_safe <- mangle_validator(parent$name_safe) 326 | assert_scalar_character(ret$name_cpp) 327 | access <- with_default(defn$access, "member") 328 | ret$access <- match_value(access, c("member", "function")) 329 | if (ret$access != "member") { 330 | ## TODO: To support free functions we need to generalise the template 331 | ## rcpp_list_definitions.whisker; specificially: 332 | ## 333 | ## {{{#class.validator}}} 334 | ## ret.{{{class.validator.name_cpp}}}(); 335 | ## {{{/class.validator}}} 336 | ## 337 | ## See method_cpp.whisker for how to do this; it's not that hard. 338 | ## I'll hold off implementing it until this basically works 339 | ## though. I also need to get the template rewriting done and 340 | ## that'll be easier to do if there's only one moving part (free 341 | ## functions and members have different rewriting rules). 342 | stop("Not yet supported") 343 | } 344 | ret 345 | } 346 | 347 | RcppR6_validate_function <- function(defn, classes) { 348 | valid <- c("name_cpp", "templates", "args", "return_type") 349 | ret <- RcppR6_validate_common(defn, valid) 350 | defn <- ret$defn 351 | ret$defn <- NULL 352 | 353 | ## These are copied over from RcppR6_validate_method: 354 | ret$return_type <- defn$return_type 355 | assert_scalar_character(ret$return_type) 356 | 357 | ret$args <- RcppR6_validate_args(defn$args, ret, "free_function", ret) 358 | ret$args <- rename(ret$args, "parent_class_name_cpp", "generic_name_cpp") 359 | 360 | ret$type <- "free_function" 361 | 362 | ## What this does is different to the class approach; this is going 363 | ## to look at the class definition and work out what the allowable 364 | ## types are. 365 | ret$templates <- 366 | RcppR6_validate_function_templates(defn$templates, classes, ret) 367 | 368 | ## And this also varies. Rather than iterating over ret$concrete 369 | ## (which does not exist here) we iterate over the same within the 370 | ## class, which at this point has been validated for us. 371 | tmp <- ret$templates$class$templates$concrete 372 | ret$concrete <- RcppR6_validate_function_concrete(tmp, ret) 373 | 374 | ret 375 | } 376 | 377 | RcppR6_validate_function_templates <- function(defn, classes, parent) { 378 | valid <- c("class", "parameters", "concrete", "infer_type") 379 | assert_list(defn) 380 | warn_unknown("templates", defn, valid) 381 | 382 | ret <- list() 383 | ret$parameters <- defn$parameters 384 | assert_scalar_character(ret$parameters) 385 | 386 | class_names <- vcapply(classes, "[[", "name_r") 387 | class_name <- match_value(defn$class, class_names) 388 | i <- match(class_name, class_names) 389 | ret$class <- classes[[i]] 390 | 391 | concrete <- vcapply(ret$class$templates$concrete, "[[", "parameters_r") 392 | if (is.null(defn$concrete)) { 393 | defn$concrete <- concrete 394 | } else { 395 | assert_character(defn$concrete) 396 | nok <- setdiff(defn$concrete, concrete) 397 | if (length(nok) > 0) { 398 | stop(sprintf("Unknown concrete types %s", collapse(nok))) 399 | } 400 | ret$concrete <- defn$concrete 401 | } 402 | 403 | ret$infer_type <- with_default(defn$infer_type, "explicit") 404 | ret$infer_type <- match_value(ret$infer_type, c("explicit", "implicit")) 405 | 406 | ## This will be different for the class generation dispatch I think, 407 | ## but there will be a lot of salvageable code. Wait until getting 408 | ## that working before trying to factor out. 409 | if (ret$infer_type == "implicit") { 410 | ## Rules here: 411 | if (length(ret$parameters) != 1L) { 412 | stop("Require exactly one template argument to use implicit dispatch") 413 | } 414 | 415 | ## This bit is bad because we use regexp to parse C++ code which 416 | ## is in general not possible. 417 | arg1_type <- parent$args$types[[1]] 418 | arg1_type <- sub("^\\s*const\\s+", "", arg1_type) 419 | arg1_type <- sub("\\s*&\\s*$", "", arg1_type) 420 | 421 | if (arg1_type == ret$parameters) { 422 | ret$infer_type_arg1_raw_parameter <- TRUE 423 | ret$infer_type_arg1_type <- ret$parameters 424 | } else { 425 | ret$infer_type_arg1_raw_parameter <- FALSE 426 | pos <- vcapply(classes, "[[", "name_cpp") 427 | i <- match(gsub("\\s", "", arg1_type), gsub("\\s", "", pos)) 428 | if (is.na(i)) { 429 | stop(sprintf("'%s' is not a RcppR6 templated class", arg1_type)) 430 | } 431 | ret$infer_type_arg1_type <- classes[[i]] 432 | } 433 | 434 | ## So, coming out of this we've added keys: 435 | ## - infer_type (string) 436 | ## - infer_type_arg1_raw_parameter (T/F) 437 | ## - infer_type_arg1_type (string) 438 | } 439 | 440 | ret 441 | } 442 | 443 | ## TODO: These can be merged and simplified considerably... 444 | RcppR6_validate_function_concrete <- function(defn, parent) { 445 | if (length(defn) > 0) { 446 | assert_list(defn) 447 | lapply(defn, cpp_template_rewrite_function, parent) 448 | } 449 | } 450 | -------------------------------------------------------------------------------- /R/RcppR6_write.R: -------------------------------------------------------------------------------- 1 | RcppR6_write <- function(dat, verbose=TRUE) { 2 | create_directories(dat$package$paths) 3 | ## There should be five things here; probably move dat around to 4 | ## make this less fragile (TODO) 5 | files <- names(dat$contents) 6 | for (file in files) { 7 | update_file(dat$contents[[file]], dat$package$files[[file]], 8 | dat$package$paths$root, verbose) 9 | } 10 | } 11 | 12 | RcppR6_install_files <- function(info, verbose=TRUE) { 13 | create_directories(info$paths) 14 | 15 | update_DESCRIPTION(info$paths$root, verbose) 16 | install_file("Makevars", info$paths$src, info$paths$root, verbose) 17 | if (!file.exists(info$files$package_include)) { 18 | template <- 19 | read_file(RcppR6_file("templates/package_include.h.whisker")) 20 | update_file(wr(template, list(package=info)), 21 | info$files$package_include, verbose) 22 | if (verbose) { 23 | message("\t...you'll need to edit this file a bunch") 24 | } 25 | } 26 | namespace <- file.path(info$paths$root, "NAMESPACE") 27 | if (!file.exists(namespace)) { 28 | if (verbose) { 29 | message("Writing empty NAMESPACE") 30 | } 31 | writeLines(character(0), namespace) 32 | } 33 | } 34 | 35 | RcppR6_run_attributes <- function(path, verbose) { 36 | if (verbose) { 37 | message("Compiling Rcpp attributes") 38 | } 39 | Rcpp::compileAttributes(path) 40 | } 41 | 42 | update_DESCRIPTION <- function(path, verbose=TRUE) { 43 | add_depends_if_missing <- function(package, field, data, verbose) { 44 | if (!depends(package, field, data)) { 45 | field <- field[[1]] 46 | if (verbose) { 47 | message(sprintf("DESCRIPTION: Adding dependency %s in field %s", 48 | package, field)) 49 | } 50 | if (field %in% names(data)) { 51 | data[[field]] <- paste(data[[field]], package, sep=", ") 52 | } else { 53 | data[[field]] <- package 54 | } 55 | } 56 | data 57 | } 58 | 59 | filename <- file.path(path, "DESCRIPTION") 60 | if (!file.exists(filename)) { 61 | stop("Did not find DESCRIPTION file to modify") 62 | } 63 | 64 | d <- d_orig <- read_dcf(filename) 65 | 66 | d <- add_depends_if_missing("Rcpp", "LinkingTo", d, verbose) 67 | d <- add_depends_if_missing("Rcpp", c("Imports", "Depends"), d, verbose) 68 | d <- add_depends_if_missing("R6", c("Imports", "Depends"), d, verbose) 69 | 70 | if (isTRUE(all.equal(d, d_orig))) { 71 | if (verbose) { 72 | message("DESCRIPTION looks good: leaving alone") 73 | } 74 | } else { 75 | s <- paste(capture.output(write.dcf(d)), collapse="\n") 76 | update_file(s, filename, path, verbose) 77 | } 78 | } 79 | 80 | uninstall <- function(path=".", verbose=TRUE, attributes=TRUE) { 81 | info <- RcppR6_package_info(path) 82 | 83 | p <- info$paths 84 | file_remove_if_exists(file.path(p$include_pkg, "RcppR6_pre.hpp"), 85 | file.path(p$include_pkg, "RcppR6_post.hpp"), 86 | file.path(p$include_pkg, "RcppR6_support.hpp"), 87 | file.path(p$R, "RcppR6.R"), 88 | file.path(p$src, "RcppR6.cpp"), 89 | verbose=verbose) 90 | ## We leave alone the package include file, Makevars, DESCRIPTION, 91 | ## even if they look like something that we've modified. 92 | if (attributes) { 93 | RcppR6_run_attributes(path, verbose) 94 | } 95 | dir_remove_if_empty(info$paths) 96 | } 97 | 98 | ## Because of the devtools issue (hadley/devtools#531) we need to use 99 | ## a non-standard temporary file location for the tests. 100 | prepare_temporary <- function(pkg, path="~/tmp") { 101 | if (!file.exists(path)) { 102 | dir.create(path) 103 | } 104 | pkg <- normalizePath(pkg) 105 | pkg_dest <- file.path(path, basename(pkg)) 106 | if (file.exists(pkg_dest)) { 107 | unlink(pkg_dest, recursive=TRUE) 108 | } 109 | file.copy(pkg, path, recursive=TRUE) 110 | invisible(pkg_dest) 111 | } 112 | -------------------------------------------------------------------------------- /R/api.R: -------------------------------------------------------------------------------- 1 | ##' Update or install RcppR6 files. This will copy required files 2 | ##' around, parse your \code{inst/classes.yml} file, and generate 3 | ##' required files. Using \code{RcppR6::install()} is equivalent to 4 | ##' passing \code{install=TRUE} to \code{RcppR6::RcppR6}. 5 | ##' 6 | ##' More details coming later! 7 | ##' @title Update Or Install RcppR6 Files 8 | ##' @param path Path to the package (this directory must contain the 9 | ##' DESCRIPTION file) 10 | ##' @param install Logical indicating if this should be treated as a 11 | ##' fresh install. Specifying \code{TRUE} (not the default) should 12 | ##' always be safe, but will copy default or skeleton copyies of files 13 | ##' into place if they do not exist, as well as update your 14 | ##' DESCRIPTION file. 15 | ##' @param attributes Should Rcpp attributes be regenerated as well? 16 | ##' This is probably a good idea (and is the default). 17 | ##' @param verbose Logical indicating if information about the process 18 | ##' will be generated. It's not all that verbose really. 19 | ##' @param force Generate code even if the class definitions (in the 20 | ##' yaml files) is unchanged and was generated with the same version 21 | ##' of RcppR6? 22 | ##' @export 23 | RcppR6 <- function(path=".", install=FALSE, 24 | attributes=TRUE, verbose=TRUE, 25 | force=FALSE) { 26 | dat <- RcppR6_read(path) 27 | 28 | skip <- FALSE 29 | if (!force) { 30 | ## TODO: probably should be using RcppR6_package_info here, but 31 | ## that reads all templates in, so not going to bother. 32 | ## Alternatively, read that in with RcppR6_read? 33 | filename_R <- file.path(path, "R", "RcppR6.R") 34 | if (file.exists(filename_R)) { 35 | x <- readLines(filename_R, n=3L) 36 | if (length(x) == 3L) { 37 | version <- sub("^## Version: ", "", x[[2]]) 38 | hash <- sub("^## Hash: ", "", x[[3]]) 39 | skip <- 40 | identical(version, as.character(packageVersion(.packageName))) && 41 | identical(hash, dat$hash) 42 | } 43 | } 44 | } 45 | 46 | if (skip) { 47 | if (verbose) { 48 | message("RcppR6 up to date") 49 | } 50 | } else { 51 | dat_valid <- RcppR6_validate(dat) 52 | ## TODO: This is surprisingly slow; whisker render is the culprit. 53 | ## Need to get that faster; might try something that allows for 54 | ## compiled templates. wr takes 92% and parseTemplate 85% so not 55 | ## great. Will need to look carefully at this and try to get it 56 | ## faster. 57 | code <- RcppR6_generate(dat_valid) 58 | if (install) { 59 | RcppR6_install_files(code$package, verbose) 60 | } 61 | RcppR6_write(code) 62 | } 63 | 64 | if (attributes) { 65 | RcppR6_run_attributes(path, verbose) 66 | } 67 | } 68 | 69 | ##' @export 70 | ##' @rdname RcppR6 71 | ##' @param ... Arguments passed to \code{RcppR6()} 72 | install <- function(...) { 73 | RcppR6(..., install=TRUE) 74 | } 75 | 76 | ##' Check that a package is ready for use with RcppR6. This just 77 | ##' checks for our requirements and prints diagnostics. It is 78 | ##' probably unsufficient, but hopefully provides enough information. 79 | ##' @title Check Package is Ready to Use 80 | ##' @return An invisible logical value indicating if the package looks 81 | ##' ready for use with RcppR6. However, if the package is not ready 82 | ##' and \code{error} is \code{TRUE}, then nothing is returned as the 83 | ##' function will throw an error. 84 | ##' @author Rich FitzJohn 85 | ##' @param path Path to the package 86 | ##' @param error Logical indicating if problems should be treated as errors 87 | ##' @param quiet Logical indicating if a description of problems 88 | ##' should be printed. 89 | ##' @export 90 | check <- function(path=".", error=TRUE, quiet=FALSE) { 91 | checks <- list(DESCRIPTION=check_DESCRIPTION(path), 92 | NAMESPACE=check_NAMESPACE(path), 93 | "Main package header"=check_header_main(path), 94 | "src/Makevars"=check_Makevars(path), 95 | "yml"=check_yml(path)) 96 | failed <- checks[sapply(checks, length) > 0] 97 | if (length(failed) > 0) { 98 | title <- paste0(names(failed), ":") 99 | body <- sapply(failed, function(x) 100 | paste(paste0("\t", x, collapse="\n"))) 101 | msg <- paste(c(rbind(title, body, deparse.level=0)), 102 | collapse="\n") 103 | msg <- paste0("RcppR6 problems found in your package:\n", msg) 104 | if (error) { 105 | stop(msg, call.=FALSE) 106 | } else if (!quiet) { 107 | message(msg) 108 | } 109 | } 110 | invisible(length(failed) == 0) 111 | } 112 | -------------------------------------------------------------------------------- /R/check.R: -------------------------------------------------------------------------------- 1 | check_DESCRIPTION <- function(path=".") { 2 | make_msg <- function(package, fields) { 3 | sprintf("Did not detect %s in %s", 4 | package, paste(fields, collapse=" or ")) 5 | } 6 | req <- list(Rcpp=c("LinkingTo"), 7 | Rcpp=c("Imports", "Depends"), 8 | R6=c("Imports", "Depends")) 9 | d <- data.frame(read.dcf(file.path(path, "DESCRIPTION")), 10 | stringsAsFactors=FALSE) 11 | f <- function(package, fields) { 12 | if (!depends(package, fields, d)) { 13 | make_msg(package, fields) 14 | } 15 | } 16 | unlist(unname(lnapply(req, f))) 17 | } 18 | 19 | check_NAMESPACE <- function(path=".") { 20 | does_import <- function(package, namespace) { 21 | for (ni in namespace$imports) { 22 | if ((is.character(ni) && identical(ni, package)) || 23 | (is.list(ni) && identical(ni[[1]], package))) { 24 | return(TRUE) 25 | } 26 | } 27 | FALSE 28 | } 29 | does_import_msg <- function(package, namespace) { 30 | if (does_import(package, n)) { 31 | character(0) 32 | } else { 33 | sprintf("NAMESPACE must import something from %s", package) 34 | } 35 | } 36 | 37 | n <- parse_ns_file(path) 38 | msg_rcpp <- does_import_msg("Rcpp", n) 39 | msg_R6 <- does_import_msg("R6", n) 40 | 41 | package <- package_name(path) 42 | 43 | if (package %in% n$dynlibs) { 44 | msg_dynlib <- character(0) 45 | } else { 46 | msg_dynlib <- sprintf("NAMESPACE must load dynamic library (%s)", 47 | package) 48 | } 49 | c(msg_rcpp, msg_R6, msg_dynlib) 50 | } 51 | 52 | check_header_main <- function(path=".") { 53 | name <- package_name(path) 54 | header <- paste0(name, ".h") 55 | header_full <- file.path(path, "inst/include", header) 56 | if (file.exists(header_full)) { 57 | ## Ideally we'll check this file for the presence of the 58 | ## appropriate includes. However, that might be organised 59 | ## differently, so I don't want to depend too strongly on it. 60 | ## Once we get libclang integration we could check for the 61 | ## inclusion of the RcppR6 headers, but I don't think at the 62 | ## moment that's tremendously worthwhile. 63 | character(0) 64 | } else { 65 | sprintf("The file %s does not exist", header_full) 66 | } 67 | } 68 | 69 | check_Makevars <- function(path=".") { 70 | filename <- file.path(path, "src", "Makevars") 71 | expected <- "-I../inst/include" 72 | 73 | if (file.exists(filename)) { 74 | d <- readLines(filename) 75 | ## Really not going to try hard to parse this file for now, but 76 | ## we'll look for the most likely string: 77 | if (any(grepl(expected, d, fixed=TRUE))) { 78 | character(0) 79 | } else { 80 | sprintf("%s must contain 'PKG_CPPFLAGS += %s'", 81 | filename, expected) 82 | } 83 | } else { 84 | sprintf("%s must exist and contain 'PKG_CPPFLAGS += %s'", 85 | filename, expected) 86 | } 87 | } 88 | 89 | check_yml <- function(path=".") { 90 | res <- try(RcppR6_validate(RcppR6_read(path, FALSE)), silent=TRUE) 91 | if (inherits(res, "try-error")) { 92 | sprintf("Error loading yml:\n\t%s\n\t", res) 93 | } else if (length(res$classes) == 0) { 94 | sprintf("No classes found in package yml") 95 | } else { 96 | character(0) 97 | } 98 | } 99 | -------------------------------------------------------------------------------- /R/cpp_templates.R: -------------------------------------------------------------------------------- 1 | ## This file refers using C++ templating rather than whisker text 2 | ## substitutions. It's all a bit unfortunate, really. 3 | cpp_template_name <- function(template, pars) { 4 | sprintf("%s<%s>", template, cpp_template_parameters(pars)) 5 | } 6 | 7 | cpp_template_parameters <- function(pars) { 8 | pars <- paste(pars, collapse=", ") 9 | cpp_pad_template(pars) 10 | } 11 | 12 | cpp_pad_template <- function(str) { 13 | if (grepl(">$", str)) { 14 | str <- paste0(str, " ") 15 | } 16 | str 17 | } 18 | 19 | cpp_template_rewrite_types <- function(x, template) { 20 | from <- names(template$parameters_cpp) 21 | to <- unname(template$parameters_cpp) 22 | 23 | ## First do any literals: 24 | i <- match(x, from) 25 | j <- !is.na(i) 26 | x[j] <- to[i[j]] 27 | 28 | ## Sort out templated types. This is very basic, probably prone to 29 | ## failure. But it serves as an interface at least. 30 | if (any(k <- !j & grepl("<", x, fixed=TRUE))) { 31 | if (any(k)) { 32 | xk <- x[k] 33 | for (i in seq_along(from)) { 34 | xk <- gsub(sprintf("\\b%s\\b", from[i]), 35 | cpp_template_parameters(to[i]), xk) 36 | } 37 | x[k] <- xk 38 | } 39 | } 40 | x 41 | } 42 | 43 | ## The idea here is to generate a concrete type by rewriting all the 44 | ## bits with the concrete representation. 45 | cpp_template_rewrite_class <- function(defn, parent, parent_class) { 46 | ret <- parent_class 47 | 48 | ret$name_r <- defn$name_r 49 | ret$name_cpp <- defn$name_cpp 50 | ret$name_safe <- defn$name_safe 51 | ret$inherits <- parent_class$name_safe 52 | ret$is_templated <- FALSE 53 | 54 | ## Bunch of type rewriting: 55 | ret$constructor <- cpp_template_rewrite_constructor(ret$constructor, defn) 56 | if (!is.null(ret$methods)) { 57 | ret$methods <- lapply(ret$methods, cpp_template_rewrite_method, defn) 58 | } 59 | if (!is.null(ret$active)) { 60 | ret$active <- lapply(ret$active, cpp_template_rewrite_active, defn) 61 | } 62 | if (!is.null(ret$list)) { 63 | ret$list <- lapply(ret$list, cpp_template_rewrite_types, defn) 64 | } 65 | ## This still needs doing, but should be pretty easy really? 66 | if (!is.null(ret$validator)) { 67 | ret$validator <- cpp_template_rewrite_validator(ret$validator, defn) 68 | } 69 | 70 | ret 71 | } 72 | 73 | cpp_template_rewrite_constructor <- function(defn, concrete) { 74 | defn$roxygen <- NULL 75 | defn$name_cpp <- cpp_template_rewrite_types(defn$name_cpp, concrete) 76 | defn$args <- cpp_template_rewrite_args(defn$args, concrete) 77 | defn 78 | } 79 | 80 | cpp_template_rewrite_method <- function(defn, concrete) { 81 | if (defn$access == "function") { 82 | defn$name_cpp <- cpp_template_rewrite_types(defn$name_cpp, concrete) 83 | } 84 | defn$return_type <- cpp_template_rewrite_types(defn$return_type, concrete) 85 | defn$args <- cpp_template_rewrite_args(defn$args, concrete) 86 | defn 87 | } 88 | 89 | cpp_template_rewrite_active <- function(defn, concrete) { 90 | if (defn$access == "function") { 91 | defn$name_cpp <- cpp_template_rewrite_types(defn$name_cpp, concrete) 92 | if (!is.null(defn$name_cpp_set)) { 93 | defn$name_cpp_set <- 94 | cpp_template_rewrite_types(defn$name_cpp_set, concrete) 95 | } 96 | } 97 | defn$type <- cpp_template_rewrite_types(defn$type, concrete) 98 | defn 99 | } 100 | 101 | cpp_template_rewrite_validator <- function(defn, concrete) { 102 | defn$name_safe <- mangle_validator(concrete$name_safe) 103 | defn 104 | } 105 | 106 | cpp_template_rewrite_args <- function(defn, concrete) { 107 | defn$types <- cpp_template_rewrite_types(defn$types, concrete) 108 | ## TODO: I think this can actually just be concrete$name_cpp 109 | defn$parent_class_name_cpp <- 110 | cpp_template_rewrite_types(defn$parent_class_name_cpp, concrete) 111 | defn 112 | } 113 | 114 | cpp_template_rewrite_function <- function(defn, parent) { 115 | ret <- parent 116 | ret$templates <- NULL 117 | 118 | ## TODO: name_safe here should actually not be 119 | ## _, but probably 120 | ## _ - that's easy enough to change 121 | ## later though. 122 | ## 123 | ## Actually, that's a really good point; what is going on here? The 124 | ## approach for now might actually be best; that way the same 125 | ## approach could work for functions that are templated but not 126 | ## against a given class? 127 | 128 | ret$name_r <- mangle_function_template(parent$name_r, defn$name_r) 129 | ret$name_safe <- mangle_function_template(parent$name_safe, defn$name_safe) 130 | 131 | ret$name_cpp <- cpp_template_rewrite_types(parent$name_cpp, defn) 132 | ret$return_type <- cpp_template_rewrite_types(parent$return_type, defn) 133 | 134 | ret$args <- cpp_template_rewrite_args(parent$args, defn) 135 | 136 | ret 137 | } 138 | -------------------------------------------------------------------------------- /R/mangle.R: -------------------------------------------------------------------------------- 1 | mangle_template_type <- function(class, template_type) { 2 | sprintf("%s___%s", class, paste(template_type, collapse="__")) 3 | } 4 | 5 | ## There are a few different options for nice mangling of templated 6 | ## names in R: 7 | ## Container.Contents # Not-quite-S3 style 8 | ## Container # C++ style 9 | ## Container(Contents) # New constructor style 10 | ## Container___Contents # Safe mangling style 11 | ## The middle two will work the best for display and for dealing with 12 | ## multiple parameters. However, it's not syntactically valid, so 13 | ## needs to go into backticks. That's not actually that bad as it 14 | ## will encourage using the generic type. 15 | mangle_template_type_r <- function(class, template_type) { 16 | sprintf("%s<%s>", class, paste(template_type, collapse=",")) 17 | } 18 | 19 | mangle_R6_generator <- function(class) { 20 | sprintf(".R6_%s", class) 21 | } 22 | 23 | mangle_active <- function(class, name, direction) { 24 | direction <- match_value(direction, c("get", "set")) 25 | sprintf("%s__%s__%s", class, name, direction) 26 | } 27 | 28 | mangle_method <- function(class, name) { 29 | sprintf("%s__%s", class, name) 30 | } 31 | 32 | mangle_constructor <- function(class) { 33 | sprintf("%s__ctor", class) 34 | } 35 | 36 | mangle_validator <- function(class) { 37 | sprintf("%s__vdor", class) 38 | } 39 | 40 | mangle_input <- function(package, name_cpp) { 41 | sprintf("%s::RcppR6::RcppR6<%s>", 42 | package, cpp_template_parameters(name_cpp)) 43 | } 44 | 45 | mangle_function_template <- function(name, type) { 46 | sprintf("%s__%s", name, type) 47 | } 48 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | package_name <- function(path=".") { 2 | read.dcf(file.path(path, "DESCRIPTION"), "Package")[[1]] 3 | } 4 | 5 | read_file <- function(...) { 6 | paste(readLines(...), collapse="\n") 7 | } 8 | 9 | with_default <- function(x, default=NULL) { 10 | if (is.null(x)) default else x 11 | } 12 | 13 | ## Really simple-minded indenting, by a number of spaces: 14 | indent <- function(str, n) { 15 | indent <- paste(rep(" ", n), collapse="") 16 | paste(indent, strsplit(str, "\n", fixed=TRUE)[[1]], 17 | sep="", collapse="\n") 18 | } 19 | 20 | ## https://github.com/viking/r-yaml/issues/5#issuecomment-16464325 21 | yaml_load <- function(string) { 22 | ## More restrictive true/false handling. Only accept if it maps to 23 | ## full true/false: 24 | handlers <- list('bool#yes' = function(x) { 25 | if (identical(toupper(x), "TRUE")) TRUE else x}, 26 | 'bool#no' = function(x) { 27 | if (identical(toupper(x), "FALSE")) FALSE else x}) 28 | yaml::yaml.load(string, handlers=handlers) 29 | } 30 | 31 | yaml_read <- function(filename) { 32 | yaml_load(read_file(filename)) 33 | } 34 | 35 | ## This is for processing data in the form 36 | ## [key1: val1, key2: val2] 37 | ## which is how args are passed in and how concrete template 38 | ## parameters are passed in. Things might not be named and that might 39 | ## be OK. 40 | yaml_seq_map <- function(dat, named=TRUE) { 41 | if (is.null(dat) || length(dat) == 0) { 42 | return(structure(list(), names=character(0))) 43 | } 44 | assert_list(dat) 45 | ## First, check that everything is length 1: 46 | if (!all(sapply(dat, length) == 1L)) { 47 | stop("Expected every element to be length 1") 48 | } 49 | dat_contents <- lapply(dat, function(x) x[[1]]) 50 | dat_names <- lapply(dat, names) 51 | dat_unnamed <- sapply(dat_names, is.null) 52 | if (named) { 53 | if (any(dat_unnamed)) { 54 | stop("All elements must be named") 55 | } 56 | } else { 57 | dat_names[dat_unnamed] <- dat_contents[dat_unnamed] 58 | } 59 | dat_names <- vapply(dat_names, identity, character(1L)) 60 | names(dat_contents) <- dat_names 61 | dat_contents 62 | } 63 | 64 | ## Pattern where we have a named list and we want to call function 65 | ## 'FUN' with rather than just 66 | ## {FUN(X[[1]], ...), ..., FUN(X[[n]], ...)} 67 | ## instead as 68 | ## {FUN{names(X)[1], X[[1]], ...}, ..., names(X)[1], X[[1]], ...} 69 | ## this can be achived via mapply, but it's not pleasant. 70 | lnapply <- function(X, FUN, ...) { 71 | nX <- names(X) 72 | res <- lapply(seq_along(X), function(i) FUN(nX[[i]], X[[i]], ...)) 73 | names(res) <- nX 74 | res 75 | } 76 | 77 | ## Determine if a package is depended on in, in any number of a set of 78 | ## fields parsed out of a DESCRIPTION file. 79 | depends <- function(package, field, data) { 80 | depend1 <- function(field) { 81 | if (field %in% colnames(data)) { 82 | package %in% parse_dep(data[, field]) 83 | } else { 84 | FALSE 85 | } 86 | } 87 | any(sapply(field, depend1)) 88 | } 89 | 90 | parse_dep <- function(x) { 91 | x <- strsplit(x, "\\s*,\\s*")[[1]] 92 | sub("[^[:alnum:].].*", "", x) 93 | } 94 | 95 | parse_ns_file <- function(path) { 96 | parseNamespaceFile(basename(path), dirname(path)) 97 | } 98 | 99 | ## Drop blank lines from a string. Used to work around some 100 | ## whisker/mustache inconsistencies. 101 | drop_blank <- function(x) { 102 | sub("^\n", "", gsub("\n[[:space:]]*\n", "\n", x)) 103 | } 104 | 105 | ## Warn if keys are found in an object that are not in a known set. 106 | warn_unknown <- function(name, defn, known) { 107 | unknown <- setdiff(names(defn), known) 108 | if (length(unknown) > 0) { 109 | warning(sprintf("Unknown fields in %s: %s", 110 | name, collapse(unknown)), 111 | immediate.=TRUE) 112 | } 113 | } 114 | 115 | collect <- function(key, data, FUN=identity, ...) { 116 | sapply(data, function(x) FUN(x[[key]], ...)) 117 | } 118 | 119 | collapse <- function(x, sep=", ") { 120 | paste(x, collapse=sep) 121 | } 122 | 123 | ## Wrapper function to help with whisker 124 | wr <- function(...) { 125 | res <- whisker::whisker.render(...) 126 | ## This is overly simple but it will do for now, given that whisker 127 | ## only outputs a few types: 128 | ## whisker::escape --> amp, lt, gt, quot 129 | ## It obviously misses CDATA entities :) 130 | if (any(grepl("&[#a-zA-Z0-9]+;", res))) { 131 | stop("HTML entities detected in translated template (use triple '{'") 132 | } 133 | res 134 | } 135 | 136 | join_lists <- function(x) { 137 | unlist(unname(x), FALSE, TRUE) 138 | } 139 | 140 | dput_to_character <- function(x) { 141 | capture.output(dput(x)) 142 | } 143 | 144 | first <- function(x) { 145 | x[[1]] 146 | } 147 | 148 | strip_trailing_newline <- function(x) { 149 | sub("\n$", "", x) 150 | } 151 | 152 | read_dcf <- function(filename, ...) { 153 | d <- data.frame(read.dcf(filename, ...), stringsAsFactors=FALSE, 154 | check.names=FALSE) 155 | ## Seems to be a bug in read.dcf: 156 | if ("Authors.R" %in% names(d)) { 157 | names(d)[names(d) == "Authors.R"] <- "Authors@R" 158 | } 159 | d 160 | } 161 | 162 | ## Like strsplit, but only splits at the *first* occurence of the 163 | ## pattern. Return value is a matrix with the first and second column 164 | ## being the left and right hand side of the match. If no match is 165 | ## found, the right column will be NA_character_. Will probably 166 | ## behave badly with things like NA values. 167 | strsplit_first <- function(x, split, 168 | fixed=FALSE, perl=FALSE, useBytes=FALSE) { 169 | info <- regexpr(split, x, 170 | fixed=fixed, perl=perl, useBytes=useBytes) 171 | match <- which(info > 0) 172 | ret <- matrix(NA_character_, length(x), 2) 173 | ret[-match,1] <- x[-match] 174 | if (length(match) > 0) { 175 | pos <- info[match] 176 | len <- attr(info, "match.length")[match] 177 | ret[match,1] <- substr(x[match], 1, pos-1) 178 | ret[match,2] <- substr(x[match], pos + len, nchar(x[match])) 179 | } 180 | ret 181 | } 182 | 183 | is_scalar_character <- function(x) { 184 | length(x) == 1L && is.character(x) 185 | } 186 | 187 | isFALSE <- function(x) { 188 | identical(x, FALSE) 189 | } 190 | 191 | vlapply <- function(X, FUN, ...) { 192 | vapply(X, FUN, logical(1), ...) 193 | } 194 | vcapply <- function(X, FUN, ...) { 195 | vapply(X, FUN, character(1), ...) 196 | } 197 | 198 | guess_namespace <- function(name) { 199 | re <- '^(::)?([[:alnum:]_:]+)::(.+)$' 200 | if (grepl(re, name)) { 201 | ns <- sub(re, "\\2", name) 202 | cl <- sub(re, "\\3", name) 203 | } else { 204 | ns <- "" 205 | cl <- name 206 | } 207 | list(namespace=ns, name=cl) 208 | } 209 | 210 | rename <- function(x, from, to) { 211 | assert_length(to, length(from), "to (arguments to rename)") 212 | i <- match(from, names(x)) 213 | if (any(is.na(i))) { 214 | stop(sprintf("Did not find name %s in object", 215 | paste(from[i], collapse=", "))) 216 | } 217 | names(x)[i] <- to 218 | x 219 | } 220 | -------------------------------------------------------------------------------- /R/utils_assert.R: -------------------------------------------------------------------------------- 1 | ## Why not use assert_that() here? It's possibly a bit slow: 2 | ## microbenchmark(assert_that(is.numeric(1)), assert_numeric(1)) 3 | ## Lazy evaluation saves us most of the time, but most of the time in 4 | ## assert_that is spent on carefully evaluating things. I'm open to 5 | ## moving to it. 6 | assert_inherits <- function(x, what, name=deparse(substitute(x))) { 7 | if (!inherits(x, what)) { 8 | stop(sprintf("%s must be a %s", name, 9 | paste(what, collapse=" / ")), call.=FALSE) 10 | } 11 | } 12 | 13 | assert_function <- function(x, name=deparse(substitute(x))) { 14 | if (!is.function(x)) { 15 | stop(sprintf("%s must be a function", name), call.=FALSE) 16 | } 17 | } 18 | 19 | assert_list <- function(x, name=deparse(substitute(x))) { 20 | if (!is.list(x)) { 21 | stop(sprintf("%s must be a list", name), call.=FALSE) 22 | } 23 | } 24 | 25 | assert_nonnegative <- function(x, name=deparse(substitute(x))) { 26 | if (x < 0) { 27 | stop(sprintf("%s must be nonnegative", name), call.=FALSE) 28 | } 29 | } 30 | 31 | assert_numeric <- function(x, name=deparse(substitute(x))) { 32 | if (!is.numeric(x)) { 33 | stop(sprintf("%s must be numeric", name), call.=FALSE) 34 | } 35 | } 36 | 37 | assert_character <- function(x, name=deparse(substitute(x))) { 38 | if (!is.character(x)) { 39 | stop(sprintf("%s must be character", name), call.=FALSE) 40 | } 41 | } 42 | 43 | assert_length <- function(x, n, name=deparse(substitute(x))) { 44 | if (length(x) != n) { 45 | stop(sprintf("%s must have %d elements", name, n), call.=FALSE) 46 | } 47 | } 48 | 49 | assert_integer <- function(x, strict=FALSE, name=deparse(substitute(x))) { 50 | if (!(is.integer(x))) { 51 | usable_as_integer <- 52 | !strict && is.numeric(x) && (max(abs(as.integer(x) - x)) < 1e-8) 53 | if (!usable_as_integer) { 54 | stop(sprintf("%s must be integer", name), call.=FALSE) 55 | } 56 | } 57 | } 58 | 59 | ## Useful for things handled with size_t, though these are passed 60 | ## through a function that will also warn. This function is preferred 61 | ## though as it generates more useful error messages -- the compiled 62 | ## one prevents crashes! 63 | assert_size <- function(x, strict=FALSE, name=deparse(substitute(x))) { 64 | assert_integer(x, strict, name) 65 | assert_nonnegative(x, name) 66 | } 67 | 68 | assert_logical <- function(x, name=deparse(substitute(x))) { 69 | if (!is.logical(x)) { 70 | stop(sprintf("%s must be logical", name), call.=FALSE) 71 | } 72 | } 73 | 74 | assert_scalar <- function(x, name=deparse(substitute(x))) { 75 | if (length(x) != 1) { 76 | stop(sprintf("%s must be a scalar", name), call.=FALSE) 77 | } 78 | } 79 | 80 | assert_nonempty <- function(x, name=deparse(substitute(x))) { 81 | if (length(x) == 0) { 82 | stop(sprintf("%s must not be empty", name), call.=FALSE) 83 | } 84 | } 85 | 86 | assert_scalar_list <- function(x, name=deparse(substitute(x))) { 87 | assert_scalar(x, name) 88 | assert_list(x, name) 89 | } 90 | 91 | assert_scalar_numeric <- function(x, name=deparse(substitute(x))) { 92 | assert_scalar(x, name) 93 | assert_numeric(x, name) 94 | } 95 | 96 | assert_scalar_integer <- function(x, strict=FALSE, 97 | name=deparse(substitute(x))) { 98 | assert_scalar(x, name) 99 | assert_integer(x, strict, name) 100 | } 101 | 102 | assert_scalar_logical <- function(x, strict=FALSE, 103 | name=deparse(substitute(x))) { 104 | assert_scalar(x, name) 105 | assert_logical(x, name) 106 | } 107 | 108 | assert_scalar_character <- function(x, strict=FALSE, 109 | name=deparse(substitute(x))) { 110 | assert_scalar(x, name) 111 | assert_character(x, name) 112 | } 113 | 114 | assert_scalar_size <- function(x, strict=FALSE, 115 | name=deparse(substitute(x))) { 116 | assert_scalar(x, name) 117 | assert_size(x, strict, name) 118 | } 119 | 120 | assert_named <- function(x, 121 | empty_can_be_unnamed=TRUE, 122 | unique_names=TRUE, 123 | name=deparse(substitute(x))) { 124 | nx <- names(x) 125 | if (is.null(nx) || any(nx == "")) { 126 | if (length(x) > 0 || !empty_can_be_unnamed) { 127 | stop(sprintf("%s must be named", name)) 128 | } 129 | } else if (any(duplicated(nx))) { 130 | stop(sprintf("%s must have unique names", name)) 131 | } 132 | } 133 | 134 | ## Like match.arg(), but does not allow for abbreviation. 135 | match_value <- function(arg, choices, msg=NULL) { 136 | assert_scalar_character(arg) 137 | if (!(arg %in% choices)) { 138 | if (is.null(msg)) { 139 | stop("'arg' must be one of ", collapse(dQuote(choices))) 140 | } else { 141 | stop(sprintf(msg, arg, collapse(dQuote(choices)))) 142 | } 143 | } 144 | arg 145 | } 146 | 147 | assert_file_exists <- function(x, name=deparse(substitute(x))) { 148 | if (!file.exists(x)) { 149 | stop(sprintf("The file '%s' does not exist", x), call.=FALSE) 150 | } 151 | } 152 | -------------------------------------------------------------------------------- /R/utils_install.R: -------------------------------------------------------------------------------- 1 | ## Utility functions for installation type things. Mostly 2 | ## installing/updating a file and reporting some information about if 3 | ## anything changed. 4 | update_file <- function(str, dest, base, verbose=TRUE) { 5 | msg <- function(...) { 6 | if (verbose) { 7 | message(...) 8 | } 9 | } 10 | 11 | dest_str <- drop_leading_path(dest, base) 12 | 13 | if (file.exists(dest)) { 14 | old <- read_file(dest) 15 | if (identical(str, old)) { 16 | msg(sprintf("%s: skipping (unchanged)", dest_str)) 17 | changed <- FALSE 18 | } else { 19 | msg(sprintf("%s: writing (changed)", dest_str)) 20 | writeLines(str, dest) 21 | changed <- TRUE 22 | } 23 | } else { 24 | message(sprintf("%s: writing (new file)", dest_str)) 25 | writeLines(str, dest) 26 | changed <- TRUE 27 | } 28 | invisible(changed) 29 | } 30 | 31 | install_file <- function(filename, dest_dir, base, verbose=TRUE, 32 | overwrite=FALSE) { 33 | dest <- file.path(dest_dir, filename) 34 | dest_str <- drop_leading_path(dest, base) 35 | file_exists <- file.exists(dest) 36 | do_copy <- overwrite || !file_exists 37 | if (verbose) { 38 | if (file_exists && overwrite) { 39 | message(sprintf("Installing file %s (overwriting)", dest_str)) 40 | } else if (!file_exists) { 41 | message(sprintf("Installing file %s (new file)", dest_str)) 42 | } 43 | } 44 | if (do_copy) { 45 | file.copy(RcppR6_file(filename), dest, overwrite=TRUE) 46 | } 47 | invisible(do_copy) 48 | } 49 | 50 | ## Basically just turn down warnings in file.remove to act more like 51 | ## shell's 'rm -f' 52 | file_remove_if_exists <- function(..., verbose=FALSE) { 53 | files <- c(...) 54 | for (f in files) { 55 | if (file.exists(f)) { 56 | if (verbose) { 57 | message("Removing file ", f) 58 | } 59 | file.remove(f) 60 | } 61 | } 62 | invisible(NULL) 63 | } 64 | 65 | dir_remove_if_empty <- function(..., verbose=FALSE) { 66 | dirs <- c(...) 67 | for (d in dirs) { 68 | if (file.exists(d) && is_directory(d) && 69 | length(dir(d, all.files=TRUE)) == 0) { 70 | if (verbose) { 71 | message("Removing empty directory ", d) 72 | } 73 | file.remove(d) 74 | } 75 | } 76 | } 77 | 78 | is_directory <- function(path) { 79 | file.info(path)[["isdir"]] 80 | } 81 | 82 | create_directories <- function(paths) { 83 | for (p in paths) { 84 | dir.create(p, FALSE, TRUE) 85 | } 86 | } 87 | 88 | drop_leading_path <- function(file, base) { 89 | ## These might want normalising but that doesn't work if the file 90 | ## doesn't exist. We could normalise on the dirname though? 91 | base <- gsub("/+", "/", base) 92 | file <- gsub("/+", "/", file) 93 | n <- nchar(base) 94 | if (identical(substr(base, 1, n), 95 | substr(file, 1, n))) { 96 | file <- sub("^/*", "", substr(file, n + 1L, nchar(file))) 97 | } 98 | file 99 | } 100 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # RcppR6 2 | 3 | [![Build Status](https://travis-ci.org/richfitz/RcppR6.png?branch=master)](https://travis-ci.org/richfitz/RcppR6) 4 | 5 | # What is this thing? 6 | 7 | This package aims to provide a simple way of generating boilerplate code for exposing C++ classes to R. It is similar in many ways to Rcpp "modules". 8 | 9 | There are [#Documentation](vignettes) explaining the idea more fully, but here is the basic idea. Suppose we have a class like this 10 | 11 | ```c++ 12 | class circle { 13 | public: 14 | double radius; 15 | circle(double r) : radius(r) {} 16 | double area() const { 17 | return M_PI * radius * radius; 18 | } 19 | double circumference() const { 20 | return M_PI * 2 * radius; 21 | } 22 | void set_circumference(double c) { 23 | if (c < 0) { 24 | Rcpp::stop("Circumference must be positive"); 25 | } 26 | radius = c / (2 * M_PI); 27 | } 28 | }; 29 | ``` 30 | 31 | This simple class represents a circle, and has one data member (`radius`), and methods to compute the area and circumference. The method `set_circumference` sets the radius so that it gives the required circumference. (Yes, this is very silly. This would also be trivial to write using `R6` or reference classes directly, but perhaps this is needed as some part of a larger set of C++ code?). 32 | 33 | To expose the class, we write a small piece of yaml: 34 | 35 | ```yaml 36 | circle: 37 | constructor: 38 | args: [radius: double] 39 | methods: 40 | area: 41 | return_type: double 42 | active: 43 | circumference: 44 | name_cpp: circumference 45 | name_cpp_set: set_circumference 46 | access: member 47 | type: double 48 | radius: {access: field, type: double} 49 | ``` 50 | 51 | After running RcppR6 on this, we can interact with objects of this type from R 52 | 53 | ```r 54 | obj <- circle(1) 55 | obj$radius # 1 56 | obj$radius <- 2 57 | obj$radius # 2 58 | obj$area() # 12.56637 59 | obj$circumference <- 1 60 | obj$circumference # 1 61 | obj$radius # 0.1591549 62 | ``` 63 | 64 | A couple of notes here: 65 | 66 | * The name of the class is the top-most yaml key - in this case 'circle'. This will generate an R function `circle` that generates R6 objects. 67 | * There are three types of entities exported: the constructor (in contrast with Rcpp modules there can be only one), methods, and active-bound fields (which simulate data members in the R6 object but using these involves calling functions behind the scenes). 68 | * In contrast with Rcpp modules we must be explicit about types, and about where methods are found. C++ is notoriusly difficult to parse, and I've avoided trying to infer these from signatures (in contrast with Rcpp attributes). This leads to some undesirable doubling up of effort. Eventually I plan on using libclang to infer types when they are ommited, but this will be optional. 69 | * This is yaml, so the format is very flexible: the last active member could be equivalently written as: 70 | 71 | ``` 72 | radius: 73 | access: field 74 | type: double 75 | ``` 76 | 77 | A full working version of this is available [here](tests/testthat/testREADME); see in particular the [class definition](tests/testthat/testREADME/inst/include/testREADME.h) and the [yaml](tests/testthat/testREADME/inst/RcppR6_classes.yml). 78 | 79 | # Documentation 80 | 81 | A vignette showing how the above example works is included in the package (`vignette("introduction", package="RcppR6")`) and rendered [here](http://htmlpreview.github.io/?https://raw.githubusercontent.com/richfitz/RcppR6/master/inst/doc/introduction.html) 82 | 83 | Slightly more useful examples are included in the examples vignette (`vignette("examples", package="RcppR6")`) and rendered [here](http://htmlpreview.github.io/?https://raw.githubusercontent.com/richfitz/RcppR6/master/inst/doc/examples.html) 84 | 85 | See how to generate interfaces to [templated types](http://htmlpreview.github.io/?https://raw.githubusercontent.com/richfitz/RcppR6/master/inst/doc/templates.html) (`vignette("templates", package="RcppR6")`) 86 | 87 | Still to come: generating big ugly parameters lists. 88 | 89 | # How is this run? 90 | 91 | RcppR6 assumes you are building a package. There is currently no support for inline use. A file `inst/include/RcppR6_classes.yml` needs to exist with class definitions (though see Configuration, below). Running `RcppR6::RcppR6()` will generate a bunch of code, and re-run Rcpp attributes. The package can then be built as usual. Importantly, your package does not need to depend on RcppR6 at all -- once the code has been generated your package is independent of RcppR6. 92 | 93 | # When is this the right sort of thing to use? 94 | 95 | * You want reference semantics 96 | * You have existing C++ code to wrap, especially templated classes 97 | * You have time consuming code that you want to expose 98 | * You don't want to write lots of boilerplate glue, and Rcpp modules won't work for you 99 | 100 | # Why not use [Rcpp modules](http://dirk.eddelbuettel.com/code/rcpp/Rcpp-modules.pdf)? 101 | 102 | * Modules can be slow to load (on a complicated project we have load times of ~5s for a package that uses modules) 103 | * The compile times using modules can be slow, and the compiler error messages are inscruitiable 104 | * Support for templated classes is patchy 105 | * There is some sort of garbage collection [issue](http://r.789695.n4.nabble.com/Reference-class-finalize-fails-with-attempt-to-apply-non-function-td4174697.html), at least on OSX that prints warnings that seem to be harmless. 106 | * It is not currently under active development, with the author apparently having left Rcpp to work on Rcpp11, and removing modules from that version! 107 | 108 | # Requirements 109 | 110 | Class definitions are written in [YAML](http://en.wikipedia.org/wiki/YAML), and parsed using the [yaml package](http://cran.r-project.org/web/packages/yaml/), from CRAN. 111 | 112 | The [Rcpp](http://rcpp.org) R package is of course needed. Interfaces this way build a set of code that is then run through Rcpp's "[attributes](http://dirk.eddelbuettel.com/code/rcpp/Rcpp-attributes.pdf)" facilities to build the actual R/C++ glue. 113 | 114 | The [R6](https://github.com/wch/R6) R package is the reference class that we use for wrapping the generated class. It's available on CRAN. It's in a state of flux though, so things may break. 115 | 116 | Roxygen comments are propagaged from the class definition into the created R files: to do anything with these you need the [devtools](https://github.com/hadley/devtools) and [roxygen2](http://cran.r-project.org/web/packages/roxygen2) packages and their dependencies. 117 | 118 | Nothing is really documented about these yet, but see the example packages in `tests/testthat`. 119 | 120 | # Preparation 121 | 122 | There are many requirements here, but almost all are really the same as work well for using Rcpp attributes. If you can use Rcpp attributes in your project, you're probably OK. 123 | 124 | 1. `DESCRIPTION`: The package must have "Rcpp" listed under `LinkingTo` and under `Imports`. `R6` must be listed under `Imports`. The Rcpp requirements here are standard for packages using Rcpp attributes. These will be set up automatically using `RcppR6::install()`. 125 | 126 | 2. `NAMESPACE`: Two requirements here: 127 | * Must import *something* from Rcpp. The [Rcpp mailing list](http://permalink.gmane.org/gmane.comp.lang.r.rcpp/6744) suggests importing `evalCpp`. 128 | * Must import *something* from R6. I suggest `R6::R6Class`. 129 | * Must load the package's dynamic library (of course) 130 | If you use roxygen these will be automatically set up for you by leaving the appropriate `@importFrom` directives in an R file. 131 | 132 | 3. A file `inst/include/.h` must exist ("main package header file"). This is the convention used by Rcpp attributes and is required for use by the `LinkingTo` convention. This file must include the definitions of classes that you want to export. It also needs to include two files: 133 | - `inst/include//RcppR6_pre.hpp` must be included *after* classes have been declared, but *before* `Rcpp.h` has been included. This is often a pain, especially if you want to use Rcpp types within the class. It may be sufficient to forward declare the classes that you export, but this will work badly with templated classes potentially (e.g., you can write `class foo;` but not `class foo`). This reason for this load order is outlined in the "[Extending Rcpp](http://cran.r-project.org/web/packages/Rcpp/vignettes/Rcpp-extending.pdf)" manual -- this file contains the prototypes for "non-intrusive extension". 134 | - `inst/include//RcppR6_post.hpp`, which may be included last in the main package header file (but must be included). `Rcpp.h` can be safely loaded before this file, and this file will itself include `Rcpp.h` if it has not been loaded. 135 | 136 | 4. `src/Makevars` must be set up to add `../inst/include/` to the header search path so that we can find the main package header. This will be automatically added by `RcppR6::install()`, but the file can simply contain a line saying `PKG_CPPFLAGS += -I../inst/include/` 137 | 138 | # Installation/updating 139 | 140 | We look after a bunch of files. 141 | 142 | * `inst/include//RcppR6_pre.hpp` 143 | * `inst/include//RcppR6_post.hpp` 144 | * `inst/include//RcppR6_support.hpp` 145 | * `src/RcppR6.cpp` 146 | * `R/RcppR6.R` 147 | 148 | These files are entirely RcppR6's - don't add anything to them. Upgrades might totally alter these files at any point. There is a little warning at the top that indicates this! The contents of these files will morph and change, and running `install()` / `RcppR6()` may alter the contents of these files. This is similar to the strategy used by Rcpp attributes. 149 | 150 | # Configuration 151 | 152 | A package may have a file `inst/RcppR6.yml` containing overall configuration information. If this file is absent, a default configuration is used. This is always available from RcppR6 (`as.yaml(RcppR6:::config_default())`) and is currently: 153 | 154 | ``` 155 | classes: inst/RcppR6_classes.yml 156 | ``` 157 | 158 | This indicates the files to search though. Multiple files can be given: 159 | 160 | ``` 161 | classes: 162 | - inst/part1.yml 163 | - inst/part2.yml 164 | ``` 165 | 166 | These will be read together before any processing happens, so the order does not matter. They are intepreted relative to the package root. 167 | 168 | It's not totally clear that keeping these files in `inst/` is the best bet, but seems preferable to many options. Having the file in inst means that it may be possible in future to define concrete versions of template classes defined in another package. If the file moves anywhere it will probably be into the root as `.RcppR6.yml`, which means that that file need adding to `.Rbuildignore`. 169 | -------------------------------------------------------------------------------- /inst/Makefile: -------------------------------------------------------------------------------- 1 | ## This is my personal project makefile, tweaked for use with 2 | ## RcppR6-using projects. 3 | 4 | ## Detect package name -- used within 'check'. Very simple minded, 5 | ## may fail in odd ways. 6 | PACKAGE := $(shell grep '^Package:' DESCRIPTION | sed -E 's/^Package:[[:space:]]+//') 7 | 8 | all: 9 | 10 | ## RcppR6 targets: 11 | RcppR6_install: 12 | Rscript -e "RcppR6::install()" 13 | 14 | RcppR6: 15 | Rscript -e "RcppR6::RcppR6()" 16 | 17 | attributes: 18 | Rscript -e "Rcpp::compileAttributes()" 19 | 20 | roxygen: 21 | @mkdir -p man 22 | Rscript -e "library(methods); devtools::document()" 23 | 24 | ## Other useful targets: 25 | install: 26 | R CMD INSTALL . 27 | 28 | build: 29 | R CMD build . 30 | 31 | check: build 32 | R CMD check --no-manual `ls -1tr ${PACKAGE}*gz | tail -n1` 33 | @rm -f `ls -1tr ${PACKAGE}*gz | tail -n1` 34 | @rm -rf ${PACKAGE}.Rcheck 35 | 36 | ## Only useful if package is set up for use with testthat, which it 37 | ## probably should be :) 38 | test: 39 | make -C tests/testthat 40 | 41 | clean: 42 | cd src && rm -f *.o *.so 43 | 44 | reset: 45 | Rscript -e "RcppR6:::uninstall()" 46 | make roxygen 47 | -------------------------------------------------------------------------------- /inst/Makevars: -------------------------------------------------------------------------------- 1 | ## -*- makefile -*- 2 | PKG_CPPFLAGS += -I../inst/include/ 3 | -------------------------------------------------------------------------------- /inst/examples/examples/.gitignore: -------------------------------------------------------------------------------- 1 | ## Normally these would not be ignored of course! 2 | R/RcppExports.R 3 | R/RcppR6.R 4 | inst/include/examples/RcppR6_post.hpp 5 | inst/include/examples/RcppR6_pre.hpp 6 | inst/include/examples/RcppR6_support.hpp 7 | src/Makevars 8 | src/RcppExports.cpp 9 | src/RcppR6.cpp 10 | man 11 | -------------------------------------------------------------------------------- /inst/examples/examples/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: examples 2 | Title: RcppR6 examples 3 | Version: 0.1 4 | Authors@R: "Rich FitzJohn [aut, cre]" 5 | Description: Examples putting RcppR6 through its paces. This package 6 | is basically ready to work with RcppR6, though it has none of the 7 | required files except that the main package include 8 | (inst/include/examples.h) has been set up ready to work, and there 9 | is a valid inst/RcppR6.yml file ready to go. 10 | Depends: 11 | R (>= 3.1.0) 12 | License: CC0 13 | Suggests: testthat 14 | -------------------------------------------------------------------------------- /inst/examples/examples/NAMESPACE: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/richfitz/RcppR6/4f11400965ce08672cdfc96b72f573990b3a22e5/inst/examples/examples/NAMESPACE -------------------------------------------------------------------------------- /inst/examples/examples/inst/RcppR6.yml: -------------------------------------------------------------------------------- 1 | classes: 2 | - inst/uniform.yml 3 | - inst/stack.yml 4 | - inst/empty.yml 5 | -------------------------------------------------------------------------------- /inst/examples/examples/inst/empty.yml: -------------------------------------------------------------------------------- 1 | empty: 2 | name_cpp: "examples::empty" 3 | forward_declare: true 4 | -------------------------------------------------------------------------------- /inst/examples/examples/inst/include/examples.h: -------------------------------------------------------------------------------- 1 | // -*-c++-*- 2 | #ifndef _EXAMPLES_H_ 3 | #define _EXAMPLES_H_ 4 | 5 | // This one I'm including early because it uses a typedef that can't 6 | // be forward declared. 7 | #include 8 | 9 | // Include this early on. It can be either after classes have been 10 | // define (but before Rcpp has been loaded) or first. This file will 11 | // attempt to provide declarations for the classes and namespaces that 12 | // you use, but this might be fragile. 13 | #include 14 | 15 | // Anything after this point is OK to include Rcpp.h. This is 16 | // probably where the meat of the included material goes if your 17 | // classes directly use Rcpp types. Otherwise you can just declare 18 | // them earlier up. 19 | #include 20 | 21 | #include 22 | 23 | // This line can safely be the last line in the file, but may go any 24 | // point after RcppR6_pre.hpp is included. 25 | #include 26 | 27 | #endif 28 | -------------------------------------------------------------------------------- /inst/examples/examples/inst/include/examples/empty.hpp: -------------------------------------------------------------------------------- 1 | #ifndef _EXAMPLES_EMPTY_HPP_ 2 | #define _EXAMPLES_EMPTY_HPP_ 3 | 4 | namespace examples { 5 | 6 | class empty { 7 | }; 8 | 9 | } 10 | 11 | #endif 12 | -------------------------------------------------------------------------------- /inst/examples/examples/inst/include/examples/stack.hpp: -------------------------------------------------------------------------------- 1 | #ifndef _EXAMPLES_STACK_HPP_ 2 | #define _EXAMPLES_STACK_HPP_ 3 | 4 | #include 5 | #include // NA_INTEGER 6 | 7 | namespace examples { 8 | 9 | // I'm going to do this via a typedef just to make this easier. 10 | // However, that's not strictly needed. 11 | typedef std::stack stack; 12 | 13 | // We'll expose methods: 14 | // * empty() (boolean) 15 | // * size() (size_t) 16 | // * top() (int) 17 | // * pop() (void) 18 | // * push() (void) 19 | 20 | // Safer versions of top, pop are desirable though, because otherwise 21 | // we can easily crash R, which is impolite. 22 | inline void pop(stack& x) { 23 | if (x.empty()) { 24 | Rcpp::stop("empty stack"); 25 | } else { 26 | x.pop(); 27 | } 28 | } 29 | inline int top(const stack& x) { 30 | if (x.empty()) { 31 | return NA_INTEGER; 32 | } else { 33 | return x.top(); 34 | } 35 | } 36 | 37 | // There are also non-member relational operators to map, such as the 38 | // equality operator. These have odd syntax, so it might be easiest 39 | // to implement with a free function (Note that this *must* be 40 | // declared inline unless the guts of it are moved into a .cpp file). 41 | inline bool stack_eq(const stack& self, const stack& other) { 42 | return self == other; 43 | } 44 | 45 | // Alternatively, this can be implemented without a wrapper: see the 46 | // 'differs' entry. 47 | 48 | } 49 | 50 | #endif 51 | -------------------------------------------------------------------------------- /inst/examples/examples/inst/include/examples/uniform.hpp: -------------------------------------------------------------------------------- 1 | #ifndef _EXAMPLES_UNIFORM_HPP_ 2 | #define _EXAMPLES_UNIFORM_HPP_ 3 | 4 | #include 5 | 6 | namespace examples { 7 | 8 | class Uniform { 9 | public: 10 | Uniform(double min_, double max_) : min(min_), max(max_) {} 11 | Rcpp::NumericVector draw(int n) const { 12 | Rcpp::RNGScope scope; 13 | return Rcpp::runif(n, min, max); 14 | } 15 | // This is additional to the Rcpp stuff, and is to exercise the 16 | // active bindings. 17 | double get_min() const { 18 | return min; 19 | } 20 | void set_min(double value) { 21 | min = value; 22 | } 23 | double min, max; 24 | }; 25 | 26 | // Because this is defined within the header, we need to declare it 27 | // inline (or it will be emmited in every compilation unit). 28 | // Alternatively just declare it: 29 | // double uniform_range(const Uniform&); 30 | // and then define the function within a cpp file within src/ 31 | // 32 | // Note that we're not using pointers (as Rcpp modules does), but 33 | // using references/const references. 34 | inline double uniform_range(const Uniform& w) { 35 | return w.max - w.min; 36 | } 37 | 38 | // This is new, compared with the modules example. Draws a single 39 | // random number. This is used to exercise the active bindings. 40 | inline Rcpp::NumericVector draw1(Uniform& x) { 41 | return x.draw(1); 42 | } 43 | 44 | // These are also new, and act as active bindings for the 'max' 45 | // element. You'd not usually use this, because that's what field is 46 | // for. 47 | inline double uniform_get_max(const Uniform& x) { 48 | return x.max; 49 | } 50 | inline void uniform_set_max(Uniform& x, double value) { 51 | x.max = value; 52 | } 53 | 54 | } 55 | 56 | #endif 57 | -------------------------------------------------------------------------------- /inst/examples/examples/inst/stack.yml: -------------------------------------------------------------------------------- 1 | stack: 2 | name_cpp: examples::stack 3 | constructor: 4 | roxygen: | 5 | @export 6 | methods: 7 | pop: 8 | return_type: void 9 | access: function 10 | name_cpp: "examples::pop" 11 | push: 12 | args: [x: "int"] 13 | return_type: void 14 | equals: 15 | args: [other: "examples::stack"] 16 | name_cpp: examples::stack_eq 17 | access: function 18 | return_type: bool 19 | differs: 20 | args: [other: "examples::stack"] 21 | name_cpp: "operator!=" 22 | access: function 23 | return_type: bool 24 | active: 25 | empty: {type: bool, access: member} 26 | size: {type: size_t, access: member} 27 | top: {type: int, access: function, 28 | name_cpp: "examples::top"} 29 | -------------------------------------------------------------------------------- /inst/examples/examples/inst/uniform.yml: -------------------------------------------------------------------------------- 1 | uniform: 2 | name_cpp: examples::Uniform 3 | forward_declare: true 4 | constructor: 5 | roxygen: | 6 | Uniform distribution 7 | @param min Lower bound of the distribution (default is zero) 8 | @param max Upper bound of the distribution (default is one) 9 | @export 10 | args: 11 | - min: double = 0.0 12 | - max: double = 1.0 13 | methods: 14 | draw: 15 | args: [n: int] 16 | return_type: Rcpp::NumericVector 17 | range: 18 | return_type: double 19 | name_cpp: examples::uniform_range 20 | access: function 21 | active: 22 | min: {type: double, access: field, readonly: true} 23 | max: {type: double, access: field, readonly: true} 24 | the_min: 25 | name_cpp: get_min 26 | name_cpp_set: set_min 27 | type: double 28 | access: member 29 | the_max: 30 | name_cpp: examples::uniform_get_max 31 | name_cpp_set: examples::uniform_set_max 32 | type: double 33 | access: function 34 | u: 35 | name_cpp: examples::draw1 # read-only: only 1 element... 36 | type: Rcpp::NumericVector 37 | access: function 38 | -------------------------------------------------------------------------------- /inst/examples/examples/tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(examples) 3 | 4 | test_check("examples") 5 | -------------------------------------------------------------------------------- /inst/examples/examples/tests/testthat/test-simple.R: -------------------------------------------------------------------------------- 1 | context("Simple Classes") 2 | 3 | test_that("empty", { 4 | e <- empty() 5 | expect_that(e, is_a("empty")) 6 | expect_that(sort(ls(e)), 7 | is_identical_to(sort(c("clone", "initialize")))) 8 | expect_that(e$.ptr, is_a("externalptr")) 9 | }) 10 | -------------------------------------------------------------------------------- /inst/examples/examples/tests/testthat/test-stack.R: -------------------------------------------------------------------------------- 1 | context("stack") 2 | 3 | test_that("Creation", { 4 | s <- stack() 5 | expect_that(s, is_a("stack")) 6 | expect_that(s, is_a("R6")) 7 | 8 | ## Some internal details: 9 | expect_that(s$.ptr, is_a("externalptr")) 10 | }) 11 | 12 | test_that("Empty stack", { 13 | s <- stack() 14 | expect_that(s$size, equals(0)) 15 | expect_that(s$empty, is_true()) 16 | ## The empty stack has a missing top, and can be popped with no 17 | ## effect. 18 | expect_that(s$top, is_identical_to(NA_integer_)) 19 | expect_that(s$pop, not(throws_error())) 20 | expect_that(s$size, equals(0)) 21 | }) 22 | 23 | test_that("Add things to the stack", { 24 | s <- stack() 25 | s$push(1) 26 | expect_that(s$size, equals(1)) 27 | expect_that(s$empty, is_false()) 28 | expect_that(s$top, equals(1)) 29 | 30 | s$push(pi) 31 | expect_that(s$top, equals(as.integer(pi))) # 3L 32 | expect_that(s$push("foo"), throws_error("not compatible")) 33 | s$push(NA) 34 | expect_that(s$top, is_identical_to(NA_integer_)) 35 | expect_that(s$size, equals(3)) 36 | }) 37 | 38 | test_that("Pop things off the stack", { 39 | s <- stack() 40 | r <- sample(5) 41 | for (i in rev(r)) { 42 | s$push(i) 43 | } 44 | expect_that(s$size, equals(length(r))) 45 | for (i in seq_along(r)) { 46 | expect_that(s$top, equals(r[[i]])) 47 | s$pop() 48 | } 49 | expect_that(s$size, equals(0)) 50 | expect_that(s$empty, is_true()) 51 | }) 52 | 53 | test_that("Comparison operators", { 54 | s <- stack() 55 | t <- stack() 56 | expect_that(s$equals(t), is_true()) 57 | expect_that(s$differs(t), is_false()) 58 | 59 | s$push(1) 60 | expect_that(s$equals(t), is_false()) 61 | expect_that(s$differs(t), is_true()) 62 | 63 | t$push(1) 64 | expect_that(s$equals(t), is_true()) 65 | expect_that(s$differs(t), is_false()) 66 | }) 67 | -------------------------------------------------------------------------------- /inst/examples/examples/tests/testthat/test-uniform.R: -------------------------------------------------------------------------------- 1 | context("uniform") 2 | 3 | test_that("Creation", { 4 | u <- uniform(0, pi) 5 | expect_that(u, is_a("uniform")) 6 | expect_that(u, is_a("R6")) 7 | 8 | ## Some internal details: 9 | expect_that(u$.ptr, is_a("externalptr")) 10 | }) 11 | 12 | test_that("Methods", { 13 | u <- uniform(0, pi) 14 | set.seed(1) 15 | r1 <- u$draw(10) 16 | set.seed(1) 17 | r2 <- runif(10, 0, pi) 18 | expect_that(r1, is_identical_to(r2)) 19 | r3 <- u$draw(10) 20 | expect_that(r3, not(equals(r1))) 21 | expect_that(u$range(), equals(pi)) 22 | }) 23 | 24 | test_that("Active", { 25 | u <- uniform(0, pi) 26 | expect_that(u$min, equals(0)) 27 | expect_that(u$max, equals(pi)) 28 | ## Member function 29 | expect_that(u$the_min, equals(0)) 30 | ## Free function 31 | expect_that(u$the_max, equals(pi)) 32 | 33 | ## Free function that modifies state 34 | set.seed(1) 35 | r <- runif(3, 0, pi) 36 | set.seed(1) 37 | for (ri in r) { 38 | expect_that(u$u, is_identical_to(ri)) 39 | } 40 | 41 | expect_that(u$min <- -1, throws_error("read-only")) 42 | expect_that(u$min, equals(0)) 43 | expect_that(u$the_min, equals(0)) 44 | 45 | u$the_min <- -2 46 | expect_that(u$min, equals(-2)) 47 | expect_that(u$the_min, equals(-2)) 48 | 49 | expect_that(u$max <- 1, throws_error("read-only")) 50 | expect_that(u$max, equals(pi)) 51 | expect_that(u$the_max, equals(pi)) 52 | 53 | u$the_max <- 2 54 | expect_that(u$max, equals(2)) 55 | expect_that(u$the_max, equals(2)) 56 | }) 57 | 58 | test_that("Defaults", { 59 | u <- uniform() 60 | expect_that(u$min, is_identical_to(0.0)) 61 | expect_that(u$max, is_identical_to(1.0)) 62 | 63 | u <- uniform(max=pi) 64 | expect_that(u$min, is_identical_to(0.0)) 65 | expect_that(u$max, is_identical_to(pi)) 66 | }) 67 | -------------------------------------------------------------------------------- /inst/examples/introduction/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: introduction 2 | Title: Code from the RcppR6 README 3 | Version: 0.1 4 | Authors.R: "Rich FitzJohn [aut, cre]" 5 | Description: Code from the RcppR6 README.md file 6 | Depends: R (>= 3.1.0) 7 | License: CC0 8 | Suggests: testthat 9 | -------------------------------------------------------------------------------- /inst/examples/introduction/NAMESPACE: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/richfitz/RcppR6/4f11400965ce08672cdfc96b72f573990b3a22e5/inst/examples/introduction/NAMESPACE -------------------------------------------------------------------------------- /inst/examples/introduction/inst/RcppR6_classes.yml: -------------------------------------------------------------------------------- 1 | circle: 2 | constructor: 3 | args: [radius: double] 4 | methods: 5 | area: 6 | return_type: double 7 | active: 8 | circumference: 9 | name_cpp: circumference 10 | name_cpp_set: set_circumference 11 | access: member 12 | type: double 13 | radius: {access: field, type: double} 14 | -------------------------------------------------------------------------------- /inst/examples/introduction/inst/include/introduction.h: -------------------------------------------------------------------------------- 1 | // -*-c++-*- 2 | #ifndef _INTRODUCTION_H_ 3 | #define _INTRODUCTION_H_ 4 | 5 | #include 6 | 7 | class circle { 8 | public: 9 | double radius; 10 | circle(double r) : radius(r) {} 11 | double area() const { 12 | return M_PI * radius * radius; 13 | } 14 | double circumference() const { 15 | return M_PI * 2 * radius; 16 | } 17 | void set_circumference(double c) { 18 | if (c < 0) { 19 | Rcpp::stop("Circumference must be positive"); 20 | } 21 | radius = c / (2 * M_PI); 22 | } 23 | }; 24 | 25 | // Include this early on. It can be either after classes have been 26 | // define (but before Rcpp has been loaded) or first. This file will 27 | // attempt to provide declarations for the classes and namespaces that 28 | // you use, but this might be fragile. 29 | #include 30 | 31 | // Anything after this point is OK to include Rcpp.h. This is 32 | // probably where the meat of the included material goes if your 33 | // classes directly use Rcpp types. Otherwise you can just declare 34 | // them earlier up. 35 | 36 | // This line can safely be the last line in the file, but may go any 37 | // point after RcppR6_pre.hpp is included. 38 | #include 39 | 40 | #endif 41 | -------------------------------------------------------------------------------- /inst/examples/introduction/tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(circle) 3 | 4 | test_check("circle") 5 | -------------------------------------------------------------------------------- /inst/examples/introduction/tests/testthat/test-circle.R: -------------------------------------------------------------------------------- 1 | context("Circle") 2 | 3 | test_that("Code from README", { 4 | obj <- circle(1) 5 | expect_that(obj, is_a("circle")) 6 | 7 | expect_that(obj$radius, equals(1)) 8 | obj$radius <- 2 9 | expect_that(obj$radius, equals(2)) 10 | expect_that(obj$area(), equals(pi * 4)) 11 | obj$circumference <- 1 12 | expect_that(obj$circumference, equals(1)) 13 | expect_that(obj$radius, equals(1 / (2 * pi))) 14 | }) 15 | -------------------------------------------------------------------------------- /inst/examples/list/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: list 2 | Title: RcppR6 list examples 3 | Version: 0.1 4 | Authors@R: "Rich FitzJohn [aut, cre]" 5 | Description: Examples for using RcppR6 to generate static list exports 6 | (so does not actually use R6 at all!) 7 | Depends: R (>= 3.1.0) 8 | License: CC0 9 | LazyData: true 10 | LinkingTo: Rcpp 11 | Imports: Rcpp, R6 12 | Suggests: 13 | testthat 14 | -------------------------------------------------------------------------------- /inst/examples/list/NAMESPACE: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/richfitz/RcppR6/4f11400965ce08672cdfc96b72f573990b3a22e5/inst/examples/list/NAMESPACE -------------------------------------------------------------------------------- /inst/examples/list/inst/RcppR6_classes.yml: -------------------------------------------------------------------------------- 1 | mystruct: 2 | forward_declare: struct 3 | name_cpp: "examples::mystruct" 4 | roxygen: | 5 | A test struct 6 | @param ...,values Values to initialise the struct with (either as 7 | variadic arguments, or as a list, but not both). 8 | @export 9 | list: 10 | - a_bool: bool 11 | - an_int: int 12 | - a_real_number: double 13 | - a_string: "std::string" 14 | 15 | validated: 16 | forward_declare: struct 17 | name_cpp: "examples::validated" 18 | list: 19 | - n_elements: int 20 | - list: "std::vector" 21 | validator: 22 | name_cpp: validate 23 | type: member 24 | 25 | triple1: 26 | name_cpp: "examples::triple1" 27 | templates: 28 | parameters: T 29 | concrete: 30 | - int 31 | - double 32 | - [string: "std::string"] 33 | list: 34 | - first: T 35 | - second: T 36 | - third: T 37 | 38 | positive: 39 | name_cpp: "examples::positive" 40 | templates: 41 | parameters: T 42 | concrete: 43 | - int 44 | - double 45 | list: 46 | - value: T 47 | validator: 48 | name_cpp: validate 49 | -------------------------------------------------------------------------------- /inst/examples/list/inst/include/list.h: -------------------------------------------------------------------------------- 1 | // -*-c++-*- 2 | #ifndef _LIST_H_ 3 | #define _LIST_H_ 4 | 5 | #include 6 | #include 7 | #include 8 | #include 9 | 10 | // Include this early on. It can be either after classes have been 11 | // defined (but before Rcpp has been loaded) or first. This file will 12 | // attempt to provide declarations for the classes and namespaces that 13 | // you use, but this might be fragile. 14 | #include 15 | 16 | // Anything after this point is OK to include Rcpp.h. This is 17 | // probably where the meat of the included material goes if your 18 | // classes directly use Rcpp types. Otherwise you can just declare 19 | // them earlier up. 20 | 21 | // This line can safely be the last line in the file, but may go any 22 | // point after RcppR6_pre.hpp is included. 23 | #include 24 | 25 | #endif 26 | -------------------------------------------------------------------------------- /inst/examples/list/inst/include/list/mystruct.hpp: -------------------------------------------------------------------------------- 1 | #ifndef _TESTEXAMPLES_MYSTRUCT_HPP_ 2 | #define _TESTEXAMPLES_MYSTRUCT_HPP_ 3 | 4 | #include 5 | 6 | namespace examples { 7 | 8 | // Here is the thing that we want to export. 9 | struct mystruct { 10 | public: 11 | bool a_bool; 12 | int an_int; 13 | double a_real_number; 14 | std::string a_string; 15 | mystruct() 16 | : a_bool(true), 17 | an_int(3), 18 | a_real_number(3.141), 19 | a_string("hello world") {} 20 | }; 21 | 22 | } 23 | 24 | #endif 25 | -------------------------------------------------------------------------------- /inst/examples/list/inst/include/list/positive.hpp: -------------------------------------------------------------------------------- 1 | #ifndef _TEMPLATES_POSITIVE_HPP_ 2 | #define _TEMPLATES_POSITIVE_HPP_ 3 | 4 | #include 5 | 6 | namespace examples { 7 | template 8 | class positive { 9 | public: 10 | typedef T data_type; 11 | T value; 12 | void validate() const { 13 | if (value < 0) { 14 | Rcpp::stop("value must be positive"); 15 | } 16 | } 17 | }; 18 | } 19 | 20 | #endif 21 | -------------------------------------------------------------------------------- /inst/examples/list/inst/include/list/triple1.hpp: -------------------------------------------------------------------------------- 1 | #ifndef _TEMPLATES_TRIPLE1_HPP_ 2 | #define _TEMPLATES_TRIPLE1_HPP_ 3 | 4 | namespace examples { 5 | // In contrast to the pair1 type, this is going to need to be 6 | // default constructible to work with list classes. 7 | template 8 | class triple1 { 9 | public: 10 | typedef T data_type; 11 | T first; 12 | T second; 13 | T third; 14 | }; 15 | } 16 | 17 | #endif 18 | -------------------------------------------------------------------------------- /inst/examples/list/inst/include/list/validated.hpp: -------------------------------------------------------------------------------- 1 | #ifndef _TESTEXAMPLES_VALIDATED_HPP_ 2 | #define _TESTEXAMPLES_VALIDATED_HPP_ 3 | 4 | #include 5 | 6 | namespace examples { 7 | 8 | // Here is the thing that we want to export. 9 | struct validated { 10 | public: 11 | int n_elements; 12 | std::vector list; 13 | validated() : n_elements(0) {} 14 | void validate() const; 15 | }; 16 | 17 | } 18 | 19 | #endif 20 | -------------------------------------------------------------------------------- /inst/examples/list/src/test.cpp: -------------------------------------------------------------------------------- 1 | // Code used in testing only. 2 | #include 3 | 4 | // [[Rcpp::export]] 5 | examples::mystruct test_flip(examples::mystruct x) { 6 | x.a_bool = !x.a_bool; 7 | return x; 8 | } 9 | -------------------------------------------------------------------------------- /inst/examples/list/src/validated.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | namespace examples { 5 | void validated::validate() const { 6 | if (n_elements < 0) { 7 | Rcpp::stop("Negative lengths are not allowed"); 8 | } 9 | if (list.size() != static_cast(n_elements)) { 10 | Rcpp::stop("list is incorrect length"); 11 | } 12 | } 13 | } 14 | -------------------------------------------------------------------------------- /inst/examples/list/tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(list) 3 | 4 | test_check("list") 5 | -------------------------------------------------------------------------------- /inst/examples/list/tests/testthat/test-mystruct.R: -------------------------------------------------------------------------------- 1 | context("mystruct") 2 | 3 | test_that("Creation", { 4 | x <- mystruct() 5 | ## This is hard coded with the default: 6 | cmp <- structure(list(a_bool=TRUE, an_int=3L, a_real_number=3.141, 7 | a_string="hello world"), 8 | class="mystruct") 9 | expect_that(x, is_identical_to(cmp)) 10 | 11 | y <- mystruct(a_bool=FALSE, an_int=4L) 12 | cmp$a_bool <- FALSE 13 | cmp$an_int <- 4L 14 | expect_that(y, is_identical_to(cmp)) 15 | 16 | z <- mystruct(values=list(an_int=100L)) 17 | expect_that(z$an_int, is_identical_to(100L)) 18 | 19 | expect_that(mystruct(foo=1), throws_error("Unknown fields: foo")) 20 | }) 21 | 22 | test_that("Loading", { 23 | x <- mystruct() 24 | x$an_int <- 7L 25 | y <- test_flip(x) 26 | expect_that(x$a_bool, is_true()) # unchanged 27 | expect_that(y$a_bool, is_false()) # changed 28 | 29 | ## Set the bool: 30 | x$a_bool <- FALSE 31 | expect_that(x, is_identical_to(y)) 32 | }) 33 | 34 | test_that("Class checking", { 35 | x <- mystruct() 36 | class(x) <- NULL 37 | expect_that(test_flip(x), 38 | throws_error("Expected an object of type mystruct")) 39 | expect_that(test_flip(NULL), 40 | throws_error("Expected an object of type mystruct")) 41 | }) 42 | -------------------------------------------------------------------------------- /inst/examples/list/tests/testthat/test-positive.R: -------------------------------------------------------------------------------- 1 | context("positive") 2 | 3 | test_that("construction", { 4 | xi <- positive("int")(value=1L) 5 | xd <- positive("double")(value=pi) 6 | 7 | expect_that(xi, is_a("positive")) 8 | expect_that(xd, is_a("positive")) 9 | 10 | expect_that(xi, is_a("positive")) 11 | expect_that(xd, is_a("positive")) 12 | 13 | expect_that(is.list(xi), is_true()) 14 | expect_that(is.list(xd), is_true()) 15 | 16 | expect_that(xi$value, is_identical_to(1L)) 17 | expect_that(xd$value, is_identical_to(pi)) 18 | 19 | expect_that(positive("int")(value=-1), 20 | throws_error("value must be positive")) 21 | expect_that(positive("double")(value=-pi), 22 | throws_error("value must be positive")) 23 | }) 24 | -------------------------------------------------------------------------------- /inst/examples/list/tests/testthat/test-triple1.R: -------------------------------------------------------------------------------- 1 | context("triple1") 2 | 3 | test_that("construction", { 4 | xi <- triple1("int")(first=1L, second=2L, third=3L) 5 | xd <- triple1("double")(first=1.1, second=2.2, third=3.3) 6 | xs <- triple1("string")(first="one", second="two", third="three") 7 | 8 | expect_that(xi, is_a("triple1")) 9 | expect_that(xd, is_a("triple1")) 10 | expect_that(xs, is_a("triple1")) 11 | 12 | expect_that(xi, is_a("triple1")) 13 | expect_that(xd, is_a("triple1")) 14 | expect_that(xs, is_a("triple1")) 15 | 16 | expect_that(is.list(xi), is_true()) 17 | expect_that(is.list(xd), is_true()) 18 | expect_that(is.list(xs), is_true()) 19 | 20 | expect_that(xi$first, is_identical_to(1L)) 21 | expect_that(xi$second, is_identical_to(2L)) 22 | expect_that(xi$third, is_identical_to(3L)) 23 | 24 | expect_that(xd$first, is_identical_to(1.1)) 25 | expect_that(xd$second, is_identical_to(2.2)) 26 | expect_that(xd$third, is_identical_to(3.3)) 27 | 28 | expect_that(xs$first, is_identical_to("one")) 29 | expect_that(xs$second, is_identical_to("two")) 30 | expect_that(xs$third, is_identical_to("three")) 31 | }) 32 | -------------------------------------------------------------------------------- /inst/examples/list/tests/testthat/test-validated.R: -------------------------------------------------------------------------------- 1 | context("validated") 2 | 3 | test_that("Creation", { 4 | x <- validated() 5 | expect_that(x, is_a("validated")) 6 | expect_that(x$n_elements, is_identical_to(0L)) 7 | expect_that(x$list, is_identical_to(numeric(0))) 8 | 9 | ## The type coersion here shows that we have gone through to C++: 10 | x <- validated(n_elements=1.0, list=pi) 11 | expect_that(x$n_elements, is_identical_to(1L)) 12 | expect_that(x$list, is_identical_to(pi)) 13 | 14 | expect_that(x <- validated(n_elements=100.0, list=pi), 15 | throws_error("list is incorrect length")) 16 | x <- validated(n_elements=100.0, list=rep(pi, 100)) 17 | expect_that(length(x$list), equals(100)) 18 | 19 | expect_that(x <- validated(n_elements=-1, list=numeric(0)), 20 | throws_error("Negative lengths are not allowed")) 21 | }) 22 | -------------------------------------------------------------------------------- /inst/examples/templates/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: templates 2 | Title: RcppR6 template examples 3 | Version: 0.1 4 | Authors@R: "Rich FitzJohn [aut, cre]" 5 | Description: Templated classes 6 | Depends: R (>= 3.1.0) 7 | License: CC0 8 | Suggests: testthat 9 | -------------------------------------------------------------------------------- /inst/examples/templates/inst/RcppR6_classes.yml: -------------------------------------------------------------------------------- 1 | pair1: 2 | name_cpp: "examples::pair1" 3 | templates: 4 | parameters: T 5 | concrete: 6 | - int 7 | - double 8 | - [string: "std::string"] 9 | constructor: 10 | args: [a: T, b: T] 11 | active: 12 | first: {type: T, access: field} 13 | second: {type: T, access: field} 14 | 15 | pair2: 16 | name_cpp: "std::pair" 17 | templates: 18 | parameters: [T1, T2] 19 | concrete: 20 | - [int, double] 21 | - [string: "std::string", double] 22 | constructor: 23 | args: [a: T1, b: T2] 24 | active: 25 | first: {type: T1, access: field} 26 | second: {type: T2, access: field} 27 | -------------------------------------------------------------------------------- /inst/examples/templates/inst/RcppR6_functions.yml: -------------------------------------------------------------------------------- 1 | pair1_sum: 2 | name_cpp: "examples::sum" 3 | templates: 4 | parameters: T 5 | class: pair1 6 | args: [obj: "examples::pair1"] 7 | return_type: T 8 | 9 | make_pair1: 10 | name_cpp: "examples::make_pair1" 11 | templates: 12 | parameters: T 13 | class: pair1 14 | args: [a: "T", b: "T"] 15 | return_type: "examples::pair1" 16 | 17 | combine: 18 | name_cpp: "examples::combine" 19 | templates: 20 | parameters: T 21 | class: pair1 22 | infer_type: implicit 23 | args: [a: "const examples::pair1&", b: "const examples::pair1&"] 24 | return_type: "examples::pair1" 25 | -------------------------------------------------------------------------------- /inst/examples/templates/inst/include/templates.h: -------------------------------------------------------------------------------- 1 | // -*-c++-*- 2 | #ifndef _TEMPLATES_H_ 3 | #define _TEMPLATES_H_ 4 | 5 | #include 6 | #include // for std::pair 7 | #include 8 | #include 9 | #include 10 | 11 | #endif 12 | -------------------------------------------------------------------------------- /inst/examples/templates/inst/include/templates/pair1.hpp: -------------------------------------------------------------------------------- 1 | #ifndef _TEMPLATES_PAIR1_HPP_ 2 | #define _TEMPLATES_PAIR1_HPP_ 3 | 4 | namespace examples { 5 | 6 | template 7 | class pair1 { 8 | public: 9 | typedef T data_type; 10 | pair1(const T& first_, const T& second_) 11 | : first(first_), second(second_) {} 12 | T first; 13 | T second; 14 | }; 15 | 16 | } 17 | 18 | #endif 19 | -------------------------------------------------------------------------------- /inst/examples/templates/inst/include/templates/pair1_functions.hpp: -------------------------------------------------------------------------------- 1 | #ifndef _TEMPLATES_PAIR1_FUNCTIONS_HPP_ 2 | #define _TEMPLATES_PAIR1_FUNCTIONS_HPP_ 3 | 4 | #include 5 | 6 | namespace examples { 7 | 8 | // Free functions that will use this: 9 | 10 | // Taking a pair as an argument 11 | template 12 | T sum(const pair1& obj) { 13 | return obj.first + obj.second; 14 | } 15 | 16 | // Return a pair as return value 17 | template 18 | pair1 make_pair1(const T& a, const T& b) { 19 | return pair1(a, b); 20 | } 21 | 22 | // Take and return 23 | template 24 | pair1 combine(const pair1& a, const pair1& b) { 25 | return pair1(a.first + b.first, a.second + b.second); 26 | } 27 | 28 | } 29 | 30 | #endif 31 | -------------------------------------------------------------------------------- /inst/examples/templates/tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(pair) 3 | 4 | test_check("pair") 5 | -------------------------------------------------------------------------------- /inst/examples/templates/tests/testthat/test-pair1.R: -------------------------------------------------------------------------------- 1 | context("pair1") 2 | 3 | test_that("construction", { 4 | xi <- pair1("int")(1L, 2L) 5 | xd <- pair1("double")(1.0, 2.0) 6 | xs <- pair1("string")("one", "two") 7 | 8 | expect_that(xi, is_a("pair1")) 9 | expect_that(xd, is_a("pair1")) 10 | expect_that(xs, is_a("pair1")) 11 | 12 | expect_that(xi, is_a("pair1")) 13 | expect_that(xd, is_a("pair1")) 14 | expect_that(xs, is_a("pair1")) 15 | 16 | expect_that(xi, is_a("R6")) 17 | expect_that(xd, is_a("R6")) 18 | expect_that(xs, is_a("R6")) 19 | 20 | expect_that(xi$first, is_identical_to(1L)) 21 | expect_that(xi$second, is_identical_to(2L)) 22 | expect_that(xd$first, is_identical_to(1.0)) 23 | expect_that(xd$second, is_identical_to(2.0)) 24 | expect_that(xs$first, is_identical_to("one")) 25 | expect_that(xs$second, is_identical_to("two")) 26 | }) 27 | 28 | test_that("functions", { 29 | xi <- make_pair1("int")(1L, 2L) 30 | expect_that(xi, is_a("pair1")) 31 | xd <- make_pair1("double")(1.1, 2.2) 32 | expect_that(xd, is_a("pair1")) 33 | xs <- make_pair1("string")("one", "two") 34 | expect_that(xs, is_a("pair1")) 35 | 36 | ## Explicit type interface: 37 | expect_that(pair1_sum("int")(xi), equals(3)) 38 | expect_that(pair1_sum("double")(xd), equals(3.3)) 39 | expect_that(pair1_sum("string")(xs), equals("onetwo")) 40 | 41 | ## Implicit type interface: 42 | xi2 <- combine(xi, xi) 43 | expect_that(xi2, is_a("pair1")) 44 | expect_that(xi2$first, equals(2L)) 45 | 46 | expect_that(combine(xi, xd), throws_error("Expected an object of type")) 47 | expect_that(combine(1, 2), throws_error("Unknown type: numeric")) 48 | 49 | xd2 <- combine(xd, xd) 50 | expect_that(xd2, is_a("pair1")) 51 | expect_that(xd2$first, equals(2.2)) 52 | 53 | xs2 <- combine(xs, xs) 54 | expect_that(xs2, is_a("pair1")) 55 | expect_that(xs2$first, equals("oneone")) 56 | }) 57 | -------------------------------------------------------------------------------- /inst/examples/templates/tests/testthat/test-pair2.R: -------------------------------------------------------------------------------- 1 | context("pair2") 2 | 3 | test_that("construction", { 4 | xid <- pair2("int", "double")(1L, 2.0) 5 | xsd <- pair2("string", "double")("one", 2.0) 6 | 7 | expect_that(xid, is_a("pair2")) 8 | expect_that(xsd, is_a("pair2")) 9 | 10 | expect_that(xid, is_a("pair2")) 11 | expect_that(xsd, is_a("pair2")) 12 | 13 | expect_that(xid, is_a("R6")) 14 | expect_that(xsd, is_a("R6")) 15 | 16 | expect_that(xid$first, is_identical_to(1L)) 17 | expect_that(xid$second, is_identical_to(2.0)) 18 | expect_that(xsd$first, is_identical_to("one")) 19 | expect_that(xsd$second, is_identical_to(2.0)) 20 | }) 21 | -------------------------------------------------------------------------------- /inst/templates/R6_generator.whisker: -------------------------------------------------------------------------------- 1 | {{{class.R6_generator}}} <- 2 | R6::R6Class( 3 | "{{{class.name_r}}}", 4 | inherit={{class.inherits}}, 5 | portable=TRUE, 6 | public=list( 7 | {{{RcppR6.R6_ptr_name}}}=NULL, 8 | initialize = function(ptr) { 9 | {{{RcppR6.r_self_name}}}${{{RcppR6.R6_ptr_name}}} <- ptr 10 | }{{{class.methods_r}}}), 11 | active=list({{{class.active_r}}})) 12 | -------------------------------------------------------------------------------- /inst/templates/R6_generator_generic.whisker: -------------------------------------------------------------------------------- 1 | {{{constructor.roxygen}}} 2 | {{{class.name_safe}}} <- function({{{constructor.types}}}) { 3 | type <- c({{{constructor.types}}}) 4 | valid <- {{{constructor.valid_r_repr}}} 5 | constructors <- {{{constructor.constructors_r_repr}}} 6 | constructors[[check_type(type, valid)]] 7 | } 8 | {{{#class.R6_generator}}} 9 | {{{class.R6_generator}}} <- R6::R6Class("{{{class.name_safe}}}") 10 | {{{/class.R6_generator}}} 11 | -------------------------------------------------------------------------------- /inst/templates/RcppR6.R_header.whisker: -------------------------------------------------------------------------------- 1 | ## Generated by RcppR6: do not edit by hand 2 | ## Version: {{{RcppR6.version}}} 3 | ## Hash: {{{package.hash}}} 4 | 5 | ##' @importFrom Rcpp evalCpp 6 | ##' @importFrom R6 R6Class 7 | ##' @useDynLib {{{package.name}}} 8 | NULL 9 | -------------------------------------------------------------------------------- /inst/templates/RcppR6.cpp_header.whisker: -------------------------------------------------------------------------------- 1 | // Generated by RcppR6 ({{{RcppR6.version}}}): do not edit by hand 2 | #include <{{{package.name}}}.h> 3 | -------------------------------------------------------------------------------- /inst/templates/RcppR6_post.hpp.whisker: -------------------------------------------------------------------------------- 1 | // Generated by RcppR6 ({{{RcppR6.version}}}): do not edit by hand 2 | #ifndef _{{{package.NAME}}}_RCPPR6_POST_HPP_ 3 | #define _{{{package.NAME}}}_RCPPR6_POST_HPP_ 4 | 5 | #include 6 | #include <{{{package.name}}}/RcppR6_support.hpp> 7 | 8 | namespace {{{package.name}}} { 9 | namespace RcppR6 { 10 | namespace traits { 11 | {{{package.RcppR6_traits}}} 12 | } 13 | } 14 | } 15 | 16 | namespace Rcpp { 17 | template 18 | SEXP wrap(const {{{package.name}}}::RcppR6::RcppR6& x) { 19 | return x.to_R6(); 20 | } 21 | 22 | namespace traits { 23 | template 24 | class Exporter<{{{package.name}}}::RcppR6::RcppR6 > { 25 | public: 26 | Exporter(SEXP x) : obj({{{package.name}}}::RcppR6::RcppR6(x)) {} 27 | inline {{{package.name}}}::RcppR6::RcppR6 get() { return obj; } 28 | private: 29 | {{{package.name}}}::RcppR6::RcppR6 obj; 30 | }; 31 | } 32 | 33 | {{{package.rcpp_definitions}}} 34 | } 35 | 36 | #endif 37 | -------------------------------------------------------------------------------- /inst/templates/RcppR6_pre.hpp.whisker: -------------------------------------------------------------------------------- 1 | // Generated by RcppR6 ({{{RcppR6.version}}}): do not edit by hand 2 | #ifndef _{{{package.NAME}}}_RCPPR6_PRE_HPP_ 3 | #define _{{{package.NAME}}}_RCPPR6_PRE_HPP_ 4 | 5 | #include 6 | 7 | 8 | namespace {{{package.name}}} { 9 | namespace RcppR6 { 10 | template class RcppR6; 11 | } 12 | } 13 | 14 | {{{package.forward_declaration}}} 15 | 16 | namespace Rcpp { 17 | template SEXP wrap(const {{{package.name}}}::RcppR6::RcppR6&); 18 | namespace traits { 19 | template class Exporter<{{{package.name}}}::RcppR6::RcppR6 >; 20 | } 21 | 22 | {{{package.rcpp_prototypes}}} 23 | } 24 | 25 | #endif 26 | -------------------------------------------------------------------------------- /inst/templates/RcppR6_support.R.whisker: -------------------------------------------------------------------------------- 1 | ## This section of code is only included where templated classes are 2 | ## included. Don't rely on the approach taken here, as it may change 3 | ## soon. 4 | check_type <- function(type, valid) { 5 | i <- match(list(type), valid, nomatch=NA) 6 | if (is.na(i)) { 7 | choices <- paste(sprintf("\t%s", sapply(valid, paste, collapse=", ")), 8 | collapse="\n") 9 | stop(sprintf("Invalid type '%s'; expected one of:\n%s", 10 | paste(type, collapse=", "), choices)) 11 | } 12 | names(valid)[[i]] 13 | } 14 | -------------------------------------------------------------------------------- /inst/templates/RcppR6_support.hpp.whisker: -------------------------------------------------------------------------------- 1 | // Generated by RcppR6 ({{{RcppR6.version}}}): do not edit by hand -*-c++-*- 2 | #ifndef _{{{package.NAME}}}_RCPPR6_SUPPORT_HPP_ 3 | #define _{{{package.NAME}}}_RCPPR6_SUPPORT_HPP_ 4 | 5 | // These functions are all used in RcppR6_post.hpp, and require Rcpp 6 | // to be loaded. 7 | // 8 | // It's possible that this will move into the RcppR6_post.hpp file 9 | // itself at some point. 10 | #include 11 | 12 | namespace {{{package.name}}} { 13 | namespace RcppR6 { 14 | 15 | // Not quite traits, but should be close enough. This is non-API! 16 | namespace traits { 17 | template 18 | std::string class_name_r() { 19 | Rcpp::stop("Unknown class"); 20 | return ""; // never get here. 21 | } 22 | template 23 | std::string package_name() { 24 | Rcpp::stop("Unknown class"); 25 | return ""; // never get here. 26 | } 27 | template 28 | std::string generator_name() { 29 | Rcpp::stop("Unknown class"); 30 | return ""; // never get here. 31 | } 32 | 33 | template 34 | std::string class_name_r(const T&) { 35 | return class_name_r(); 36 | } 37 | template 38 | std::string package_name(const T&) { 39 | return package_name(); 40 | } 41 | template 42 | std::string generator_name(const T&) { 43 | return generator_name(); 44 | } 45 | } 46 | 47 | // In parallel/contrast with Rcpp::is :) 48 | // 49 | // This will throw a *compile time* error if T is not a type known to 50 | // RcppR6. It will return false at runtime if x is not the required 51 | // type. 52 | // 53 | // Note that this does not actually check that we inherit from R6. 54 | // Strictly we should look for the classname, then from that position 55 | // check that we hit R6. But omelettes and eggs and all that. 56 | // 57 | // It would be nice to roll this into Rcpp::is, but I don't really see 58 | // how to do that -- Rcpp::is mostly seems to use things in 59 | // Rcpp::internal and I don't see any examples of extending things. 60 | // 61 | // Use this by doing: 62 | // {{{package.name}}}::RcppR6::is(x) 63 | template 64 | bool is(Rcpp::RObject x) { 65 | return x.inherits(traits::class_name_r().c_str()); 66 | } 67 | 68 | template 69 | void check_ptr_valid(Rcpp::XPtr p) { 70 | T* test = p; 71 | if (test == NULL) { 72 | Rcpp::stop("Pointer is NULL"); 73 | } 74 | } 75 | 76 | // This is absolutely basic, and does not do much more than XPtr. 77 | // Differences are: 78 | // - pointer validity checking when an externalptr is recieved. 79 | // - knows what "type" of pointer it contains and checks this when 80 | // recieved 81 | // - can generate a special R6 object on return 82 | // 83 | // Possible improvements: 84 | // - the appropriate generator should really be a static member of 85 | // the class, which we generate only when it's not been 86 | // initialised yet. That will save a few calls, but will take 87 | // care through a load/unload cycle. 88 | // - first-class access to *general* R6 classes would be preferable 89 | // to the dodgy 'find' call. 90 | template 91 | class RcppR6 { 92 | public: 93 | RcppR6(SEXP x) : ptr(ptr_from_R6(x)) {} 94 | RcppR6(const T& x) : ptr(new T(x), true) {} 95 | T& operator*() const { 96 | return *ptr; 97 | } 98 | inline operator T*(){ return (T*)(ptr); } 99 | T* operator->() const { 100 | return &(*ptr); 101 | } 102 | Rcpp::XPtr ptr; 103 | // Convert from an R6 object from R: 104 | static Rcpp::XPtr ptr_from_R6(Rcpp::RObject x) { 105 | if (is(x)) { 106 | Rcpp::Environment xe = Rcpp::as(x); 107 | Rcpp::XPtr ptr = Rcpp::as >(xe["{{{RcppR6.R6_ptr_name}}}"]); 108 | check_ptr_valid(ptr); 109 | return ptr; 110 | } else { 111 | Rcpp::stop("Expected an object of type R6 / " + 112 | traits::class_name_r()); 113 | return Rcpp::as >(x); // Won't get here 114 | } 115 | } 116 | SEXP to_R6() const { 117 | const std::string packagename(traits::package_name()); 118 | const std::string generatorname(traits::generator_name()); 119 | Rcpp::Environment base("package:base"); 120 | Rcpp::Function getNamespace = base["getNamespace"]; 121 | Rcpp::Environment pkg = getNamespace(packagename); 122 | // TODO: need to deal with failure here (i.e. R_NilValue), or we 123 | // get a really hard to diagnose error message. 124 | Rcpp::Environment Generator = pkg[generatorname]; 125 | Rcpp::Function Generator_new = Generator["new"]; 126 | return Generator_new(ptr); 127 | } 128 | }; 129 | 130 | } 131 | } 132 | 133 | #endif 134 | -------------------------------------------------------------------------------- /inst/templates/RcppR6_traits.whisker: -------------------------------------------------------------------------------- 1 | template <> inline std::string class_name_r<{{{class.name_cpp}}} >() {return "{{{class.name_r}}}";} 2 | template <> inline std::string package_name<{{{class.name_cpp}}} >() {return "{{{package.name}}}";} 3 | template <> inline std::string generator_name<{{{class.name_cpp}}} >() {return "{{{class.R6_generator}}}";} 4 | -------------------------------------------------------------------------------- /inst/templates/active_cpp.whisker: -------------------------------------------------------------------------------- 1 | // [[Rcpp::export]] 2 | {{{active.return_type}}} {{{active.name_safe_get}}}({{{active.input_type}}} {{{RcppR6.input_name}}}) { 3 | {{{#active.is_field}}} 4 | return {{{RcppR6.input_name}}}->{{{active.name_cpp}}}; 5 | {{{/active.is_field}}} 6 | {{{#active.is_member}}} 7 | return {{{RcppR6.input_name}}}->{{{active.name_cpp_get}}}(); 8 | {{{/active.is_member}}} 9 | {{{#active.is_function}}} 10 | return {{{active.name_cpp_get}}}(*{{{RcppR6.input_name}}}); 11 | {{{/active.is_function}}} 12 | } 13 | {{^active.is_readonly}} 14 | // [[Rcpp::export]] 15 | void {{{active.name_safe_set}}}({{{active.input_type}}} {{{RcppR6.input_name}}}, {{{active.return_type}}} {{{RcppR6.r_value_name}}}) { 16 | {{{#active.is_field}}} 17 | {{{RcppR6.input_name}}}->{{{active.name_cpp}}} = {{{RcppR6.r_value_name}}}; 18 | {{{/active.is_field}}} 19 | {{{#active.is_member}}} 20 | {{{RcppR6.input_name}}}->{{{active.name_cpp_set}}}({{{RcppR6.r_value_name}}}); 21 | {{{/active.is_member}}} 22 | {{{#active.is_function}}} 23 | {{{active.name_cpp_set}}}(*{{{RcppR6.input_name}}}, {{{RcppR6.r_value_name}}}); 24 | {{{/active.is_function}}} 25 | } 26 | {{/active.is_readonly}} 27 | -------------------------------------------------------------------------------- /inst/templates/active_r.whisker: -------------------------------------------------------------------------------- 1 | {{{active.name_r}}} = function({{{RcppR6.r_value_name}}}) { 2 | if (missing({{{RcppR6.r_value_name}}})) { 3 | {{{active.name_safe_get}}}({{{RcppR6.r_self_name}}}) 4 | } else { 5 | {{#active.is_readonly}} 6 | stop("{{{active.class_name_r}}}${{{active.name_r}}} is read-only") 7 | {{/active.is_readonly}} 8 | {{^active.is_readonly}} 9 | {{{active.name_safe_set}}}({{{RcppR6.r_self_name}}}, {{{RcppR6.r_value_name}}}) 10 | {{/active.is_readonly}} 11 | } 12 | } 13 | -------------------------------------------------------------------------------- /inst/templates/constructor_cpp.whisker: -------------------------------------------------------------------------------- 1 | // [[Rcpp::export]] 2 | {{{constructor.return_type}}} {{{constructor.name_safe}}}({{{constructor.args.defn_cpp}}}) { 3 | return {{{constructor.name_cpp}}}({{{constructor.args.body_cpp}}}); 4 | } 5 | -------------------------------------------------------------------------------- /inst/templates/constructor_list_cpp.whisker: -------------------------------------------------------------------------------- 1 | // [[Rcpp::export]] 2 | SEXP {{{class.constructor.name_cpp}}}() { 3 | return Rcpp::wrap({{{class.name_cpp}}}()); 4 | } 5 | {{{#class.validator}}} 6 | // [[Rcpp::export]] 7 | SEXP {{{class.validator.name_safe}}}(SEXP obj) { 8 | return Rcpp::wrap(Rcpp::as<{{{class.name_cpp}}} >(obj)); 9 | } 10 | {{{/class.validator}}} 11 | -------------------------------------------------------------------------------- /inst/templates/constructor_r.whisker: -------------------------------------------------------------------------------- 1 | {{{constructor.roxygen}}} 2 | `{{{class.name_r}}}` <- function({{{constructor.args.defn_r}}}) { 3 | {{{constructor.name_safe}}}({{{constructor.args.body_r}}}) 4 | } 5 | -------------------------------------------------------------------------------- /inst/templates/function_concrete.whisker: -------------------------------------------------------------------------------- 1 | // [[Rcpp::export]] 2 | {{{function.return_type}}} {{{function.name_safe}}}({{{function.args.defn_cpp}}}) { 3 | {{{function.return_statement}}}{{{function.name_cpp}}}({{{function.args.body_cpp}}}); 4 | } 5 | -------------------------------------------------------------------------------- /inst/templates/function_generic_explicit.whisker: -------------------------------------------------------------------------------- 1 | {{{function.name_r}}} <- function({{{function.types}}}) { 2 | type <- c({{{function.types}}}) 3 | valid <- {{{function.valid_r_repr}}} 4 | functions <- {{{function.functions_r_repr}}} 5 | functions[[check_type(type, valid)]] 6 | } 7 | -------------------------------------------------------------------------------- /inst/templates/function_generic_implicit.whisker: -------------------------------------------------------------------------------- 1 | {{{function.name_r}}} <- function({{{function.args.defn_r}}}) { 2 | cl <- class({{{function.arg1_name}}})[[1]] 3 | switch(cl, 4 | {{{function.switch_body}}}, 5 | stop("Unknown type: ", cl))({{{function.args.body_r}}}) 6 | } 7 | -------------------------------------------------------------------------------- /inst/templates/list_generator.whisker: -------------------------------------------------------------------------------- 1 | {{{class.constructor.roxygen}}} 2 | `{{{class.constructor.name_r}}}` <- function(..., values=list(...)) { 3 | ret <- {{{class.constructor.name_cpp}}}() 4 | if (length(values) > 0L) { 5 | if (is.null(names(values)) || any(names(values) == "")) { 6 | stop("All values must be named") 7 | } 8 | if (length(err <- setdiff(names(values), names(ret))) > 0L) { 9 | stop(sprintf("Unknown fields: %s", paste(err, collapse=", "))) 10 | } 11 | to_set <- intersect(names(values), names(ret)) 12 | ret[to_set] <- values[to_set] 13 | } 14 | {{{#class.validator}}} 15 | {{{class.validator.name_safe}}}(ret) 16 | {{{/class.validator}}} 17 | {{{^class.validator}}} 18 | ret 19 | {{{/class.validator}}} 20 | } 21 | -------------------------------------------------------------------------------- /inst/templates/method_cpp.whisker: -------------------------------------------------------------------------------- 1 | // [[Rcpp::export]] 2 | {{{method.return_type}}} {{{method.name_safe}}}({{{method.args.defn_cpp}}}) { 3 | {{{#method.is_member}}} 4 | {{{method.return_statement}}}{{{RcppR6.input_name}}}->{{{method.name_cpp}}}({{{method.args.body_cpp}}}); 5 | {{{/method.is_member}}} 6 | {{{#method.is_function}}} 7 | {{{method.return_statement}}}{{{method.name_cpp}}}({{{method.args.body_cpp}}}); 8 | {{{/method.is_function}}} 9 | } 10 | -------------------------------------------------------------------------------- /inst/templates/method_r.whisker: -------------------------------------------------------------------------------- 1 | {{{method.name_r}}} = function({{{method.args.defn_r}}}) { 2 | {{{method.name_safe}}}({{{method.args.body_r}}}) 3 | } 4 | -------------------------------------------------------------------------------- /inst/templates/package_include.h.whisker: -------------------------------------------------------------------------------- 1 | // -*-c++-*- 2 | #ifndef _{{{package.NAME}}}_H_ 3 | #define _{{{package.NAME}}}_H_ 4 | 5 | // Include this early on. It can be either after classes have been 6 | // defined (but before Rcpp has been loaded) or first. This file will 7 | // attempt to provide declarations for the classes and namespaces that 8 | // you use, but this might be fragile. 9 | #include <{{{package.name}}}/RcppR6_pre.hpp> 10 | 11 | // Anything after this point is OK to include Rcpp.h. This is 12 | // probably where the meat of the included material goes if your 13 | // classes directly use Rcpp types. Otherwise you can just declare 14 | // them earlier up. 15 | 16 | // This line can safely be the last line in the file, but may go any 17 | // point after RcppR6_pre.hpp is included. 18 | #include <{{{package.name}}}/RcppR6_post.hpp> 19 | 20 | #endif 21 | -------------------------------------------------------------------------------- /inst/templates/rcpp_definitions.whisker: -------------------------------------------------------------------------------- 1 | template <> inline SEXP wrap(const {{{class.name_cpp}}}& x) { 2 | return wrap({{{class.input_type}}}(x)); 3 | } 4 | template <> inline {{{class.name_cpp}}} as(SEXP x) { 5 | return *({{{class.input_type}}}(x)); 6 | } 7 | -------------------------------------------------------------------------------- /inst/templates/rcpp_list_definitions.whisker: -------------------------------------------------------------------------------- 1 | template <> inline SEXP wrap(const {{{class.name_cpp}}}& x) { 2 | Rcpp::List ret; 3 | {{{#class.fields}}} 4 | ret["{{{field_name}}}"] = Rcpp::wrap(x.{{{field_name}}}); 5 | {{{/class.fields}}} 6 | {{{#class.inherits}}} 7 | ret.attr("class") = Rcpp::CharacterVector::create("{{{class.name_r}}}", "{{{class.inherits}}}"); 8 | {{{/class.inherits}}} 9 | {{{^class.inherits}}} 10 | ret.attr("class") = "{{{class.name_r}}}"; 11 | {{{/class.inherits}}} 12 | return ret; 13 | } 14 | template <> inline {{{class.name_cpp}}} as(SEXP x) { 15 | if (!{{package.name}}::RcppR6::is<{{{class.name_cpp}}} >(x)) { 16 | Rcpp::stop("Expected an object of type {{{class.name_r}}}"); 17 | // NOTE: Won't drop through or return anything. 18 | } 19 | // NOTE: assumes default constructable, and will assign *every* 20 | // field twice. No current support for a hook. 21 | {{{class.name_cpp}}} ret; 22 | Rcpp::List xl(x); 23 | {{{#class.fields}}} 24 | // ret.{{{field_name}}} = Rcpp::as(xl["{{{field_name}}}"]); 25 | ret.{{{field_name}}} = Rcpp::as<{{{field_type}}} >(xl["{{{field_name}}}"]); 26 | {{{/class.fields}}} 27 | {{{#class.validator}}} 28 | ret.{{{class.validator.name_cpp}}}(); 29 | {{{/class.validator}}} 30 | return ret; 31 | } 32 | -------------------------------------------------------------------------------- /inst/templates/rcpp_prototypes.whisker: -------------------------------------------------------------------------------- 1 | template <> SEXP wrap(const {{{class.name_cpp}}}&); 2 | template <> {{{class.name_cpp}}} as(SEXP); 3 | -------------------------------------------------------------------------------- /inst/vignette_common.R: -------------------------------------------------------------------------------- 1 | yaml_load <- RcppR6:::yaml_load 2 | 3 | lang_output <- function(x, lang) { 4 | cat(c(sprintf("```%s", lang), x, "```"), sep="\n") 5 | } 6 | cpp_output <- function(x) lang_output(x, "c++") 7 | r_output <- function(x) lang_output(x, "r") 8 | yaml_output <- function(x) lang_output(x, "yaml") 9 | plain_output <- function(x) lang_output(x, "plain") 10 | 11 | tree <- function(path, header=path) { 12 | paste1 <- function(a, b) { 13 | paste(rep_len(a, length(b)), b) 14 | } 15 | indent <- function(x, files) { 16 | paste0(if (files) "| " else " ", x) 17 | } 18 | is_directory <- function(x) { 19 | unname(file.info(x)[, "isdir"]) 20 | } 21 | prefix_file <- "|--=" 22 | prefix_dir <- "|-+=" 23 | 24 | files <- dir(path) 25 | files_full <- file.path(path, files) 26 | isdir <- is_directory(files_full) 27 | 28 | ret <- as.list(c(paste1(prefix_dir, files[isdir]), 29 | paste1(prefix_file, files[!isdir]))) 30 | files_full <- c(files_full[isdir], files_full[!isdir]) 31 | isdir <- c(isdir[isdir], isdir[!isdir]) 32 | 33 | n <- length(ret) 34 | ret[[n]] <- sub("|", "\\", ret[[n]], fixed=TRUE) 35 | tmp <- lapply(which(isdir), function(i) 36 | c(ret[[i]], indent(tree(files_full[[i]], NULL), !all(isdir)))) 37 | ret[isdir] <- tmp 38 | 39 | c(header, unlist(ret)) 40 | } 41 | 42 | vignette_prepare <- function(name) { 43 | path <- system.file(file.path("examples", name), package="RcppR6") 44 | path <- RcppR6:::prepare_temporary(path, tempfile()) 45 | unlink(file.path(path, "tests"), recursive=TRUE) 46 | descr <- readLines(file.path(path, "DESCRIPTION")) 47 | descr <- descr[!grepl("Suggests: testthat", descr, fixed=TRUE)] 48 | writeLines(descr, file.path(path, "DESCRIPTION")) 49 | path 50 | } 51 | -------------------------------------------------------------------------------- /man/RcppR6.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.1.1): do not edit by hand 2 | % Please edit documentation in R/api.R 3 | \name{RcppR6} 4 | \alias{RcppR6} 5 | \alias{install} 6 | \title{Update Or Install RcppR6 Files} 7 | \usage{ 8 | RcppR6(path = ".", install = FALSE, attributes = TRUE, verbose = TRUE, 9 | force = FALSE) 10 | 11 | install(...) 12 | } 13 | \arguments{ 14 | \item{path}{Path to the package (this directory must contain the 15 | DESCRIPTION file)} 16 | 17 | \item{install}{Logical indicating if this should be treated as a 18 | fresh install. Specifying \code{TRUE} (not the default) should 19 | always be safe, but will copy default or skeleton copyies of files 20 | into place if they do not exist, as well as update your 21 | DESCRIPTION file.} 22 | 23 | \item{attributes}{Should Rcpp attributes be regenerated as well? 24 | This is probably a good idea (and is the default).} 25 | 26 | \item{verbose}{Logical indicating if information about the process 27 | will be generated. It's not all that verbose really.} 28 | 29 | \item{force}{Generate code even if the class definitions (in the 30 | yaml files) is unchanged and was generated with the same version 31 | of RcppR6?} 32 | 33 | \item{...}{Arguments passed to \code{RcppR6()}} 34 | } 35 | \description{ 36 | Update or install RcppR6 files. This will copy required files 37 | around, parse your \code{inst/classes.yml} file, and generate 38 | required files. Using \code{RcppR6::install()} is equivalent to 39 | passing \code{install=TRUE} to \code{RcppR6::RcppR6}. 40 | } 41 | \details{ 42 | More details coming later! 43 | } 44 | 45 | -------------------------------------------------------------------------------- /man/check.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.1.1): do not edit by hand 2 | % Please edit documentation in R/api.R 3 | \name{check} 4 | \alias{check} 5 | \title{Check Package is Ready to Use} 6 | \usage{ 7 | check(path = ".", error = TRUE, quiet = FALSE) 8 | } 9 | \arguments{ 10 | \item{path}{Path to the package} 11 | 12 | \item{error}{Logical indicating if problems should be treated as errors} 13 | 14 | \item{quiet}{Logical indicating if a description of problems 15 | should be printed.} 16 | } 17 | \value{ 18 | An invisible logical value indicating if the package looks 19 | ready for use with RcppR6. However, if the package is not ready 20 | and \code{error} is \code{TRUE}, then nothing is returned as the 21 | function will throw an error. 22 | } 23 | \description{ 24 | Check that a package is ready for use with RcppR6. This just 25 | checks for our requirements and prints diagnostics. It is 26 | probably unsufficient, but hopefully provides enough information. 27 | } 28 | \author{ 29 | Rich FitzJohn 30 | } 31 | 32 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(RcppR6) 3 | 4 | test_check("RcppR6") 5 | -------------------------------------------------------------------------------- /tests/testthat/Makefile: -------------------------------------------------------------------------------- 1 | RUN_TESTS="library(methods); library(testthat); test_dir('.')" 2 | test: 3 | Rscript -e $(RUN_TESTS) 4 | .PHONY: test 5 | -------------------------------------------------------------------------------- /tests/testthat/helper-RcppR6.R: -------------------------------------------------------------------------------- 1 | passes_tests <- function() { 2 | function(package) { 3 | res <- devtools::test(package) 4 | expectation(sum(as.data.frame(res)$failed) == 0, 5 | "tests failed", "tests passed") 6 | } 7 | } 8 | -------------------------------------------------------------------------------- /tests/testthat/test-README.R: -------------------------------------------------------------------------------- 1 | context("README") 2 | 3 | test_that("README", { 4 | ## Because of the devtools issue (hadley/devtools#531) we need to use 5 | ## a non-standard temporary file location for the tests. 6 | path <- system.file("examples/introduction", package="RcppR6") 7 | pkg <- RcppR6:::prepare_temporary(path) 8 | 9 | RcppR6::install(pkg) 10 | devtools::document(pkg) 11 | expect_that(RcppR6::check(pkg), not(throws_error())) 12 | ## fresh=TRUE here would be nice, but can't happen. 13 | expect_that(pkg, passes_tests()) 14 | ## Should always clean up here, really. Will go away when the 15 | ## tempdir issue does. 16 | unlink(pkg, recursive=TRUE) 17 | }) 18 | -------------------------------------------------------------------------------- /tests/testthat/test-examples.R: -------------------------------------------------------------------------------- 1 | context("examples") 2 | 3 | test_that("examples", { 4 | ## Because of the devtools issue (hadley/devtools#531) we need to use 5 | ## a non-standard temporary file location for the tests. 6 | path <- system.file("examples/examples", package="RcppR6") 7 | pkg <- RcppR6:::prepare_temporary(path) 8 | 9 | RcppR6::install(pkg) 10 | devtools::document(pkg) 11 | expect_that(RcppR6::check(pkg), not(throws_error())) 12 | ## fresh=TRUE here would be nice, but can't happen. 13 | expect_that(pkg, passes_tests()) 14 | 15 | expect_that(RcppR6::install(pkg), shows_message("RcppR6 up to date")) 16 | 17 | ## Should always clean up here, really. Will go away when the 18 | ## tempdir issue does. 19 | unlink(pkg, recursive=TRUE) 20 | }) 21 | -------------------------------------------------------------------------------- /tests/testthat/test-list.R: -------------------------------------------------------------------------------- 1 | context("list") 2 | 3 | test_that("list", { 4 | path <- system.file("examples/list", package="RcppR6") 5 | pkg <- RcppR6:::prepare_temporary(path) 6 | 7 | RcppR6::install(pkg) 8 | devtools::document(pkg) 9 | expect_that(RcppR6::check(pkg), not(throws_error())) 10 | ## fresh=TRUE here would be nice, but can't happen. 11 | expect_that(pkg, passes_tests()) 12 | ## Should always clean up here, really. Will go away when the 13 | ## tempdir issue does. 14 | unlink(pkg, recursive=TRUE) 15 | }) 16 | -------------------------------------------------------------------------------- /tests/testthat/test-templates.R: -------------------------------------------------------------------------------- 1 | context("pair") 2 | 3 | test_that("pair", { 4 | path <- system.file("examples/templates", package="RcppR6") 5 | pkg <- RcppR6:::prepare_temporary(path) 6 | RcppR6::install(pkg) 7 | devtools::document(pkg) 8 | expect_that(RcppR6::check(pkg), not(throws_error())) 9 | devtools::load_all(pkg) 10 | ## fresh=TRUE here would be nice, but can't happen. 11 | expect_that(pkg, passes_tests()) 12 | ## Should always clean up here, really. Will go away when the 13 | ## tempdir issue does. 14 | unlink(pkg, recursive=TRUE) 15 | }) 16 | -------------------------------------------------------------------------------- /vignettes/examples.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "RcppR6 examples" 3 | author: "Rich FitzJohn" 4 | date: "`r Sys.Date()`" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{RcppR6 examples} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | %\VignetteEncoding{UTF-8} 10 | --- 11 | 12 | This vignette builds on the introduction one to provide a 13 | marginally more useful example, and demonstrate a few more features 14 | of RcppR6. 15 | 16 | The code used here is a demo package called `examples`, available 17 | within RcppR6 (`system.file("examples/examples", 18 | package="RcppR6")`), and like the `introduction` package doesn't 19 | really do anything that you'd really want to do, or need RcppR6 to 20 | do. 21 | 22 | ``` {r echo=FALSE, results="asis"} 23 | set.seed(1) 24 | source(system.file("vignette_common.R", package="RcppR6")) 25 | path <- vignette_prepare("examples") 26 | plain_output(tree(path, "introduction")) 27 | ``` 28 | 29 | This package defines three classes, of varying complexity. It uses 30 | a different way of structuring sources to `introduction`; 31 | 32 | ``` {r echo=FALSE, results="asis"} 33 | yaml_output(readLines(file.path(path, "inst/RcppR6.yml"))) 34 | ``` 35 | 36 | Rather than a single file `inst/RcppR6_classes.yml`, there is a 37 | file `inst/RcppR6.yml` that lists files to include, relative to the 38 | package root. This isn't necessary, but might help with 39 | organisation. Each file can define one or more classes -- here 40 | they define a single class each. 41 | 42 | Similarly, the definitions are spread over three files: 43 | `inst/include/examples/uniform.hpp`, 44 | `inst/include/examples/stack.hpp` and 45 | `inst/include/examples/empty.hpp`. 46 | 47 | ## `uniform` 48 | 49 | This is a similar example to the Rcpp modules example of a uniform 50 | distribution object. It's not identical to the modules version. 51 | ``` {r echo=FALSE, results="asis"} 52 | cpp_output(readLines(file.path(path, "inst/include/examples/uniform.hpp"))) 53 | ``` 54 | 55 | The `Rcpp::RNGScope` bit is probably not needed, actually as Rcpp 56 | attributes will sort that out for us. 57 | 58 | The example is declared with a namespace `examples`; unlike 59 | attributes, RcppR6 does not have a problem exporting things that 60 | are not in the global namespace. This comes in useful for wrapping 61 | library code. 62 | 63 | In addition to the class definition, there are also some free 64 | functions defined; `uniform_get_max` and `uniform_set_max`; these 65 | are going to be used to set up active members in the R6 class for 66 | getting and setting the `max` field of the class. This pattern 67 | (free functions) is useful if you want to do additional error 68 | checking on inputs when calling from R than when calling from C++ 69 | (e.g., passing an `int` into a function that expects an unsigned 70 | integer). 71 | 72 | Note that the getter takes first argument of type `const Uniform&`; 73 | a const reference to a `Uniform` object. A non-const reference 74 | would be fine here, as would a *copy* of the object. The setter 75 | takes first argument `Uniform&`; this needs to be a reference (and 76 | not a pointer). Passing in a copy here will *appear* to work (as 77 | in; will compile and run) but will not change the value. 78 | 79 | The `yaml` for this: 80 | ``` {r echo=FALSE, results="asis"} 81 | yaml_output(readLines(file.path(path, "inst/uniform.yml"))) 82 | ``` 83 | 84 | In order: 85 | 86 | ```yaml 87 | uniform: 88 | name_cpp: examples::Uniform 89 | ``` 90 | 91 | This means that the name of the class on the R side will be 92 | *different* to the name on the C++ side. We'll export the class as 93 | `uniform` (so that `uniform(...)` will be the constructor in R) but 94 | that the actuall class we are wrapping is called 95 | `examples::Uniform`. This is how RcppR6 deals with namespaces -- 96 | just provide the fully qualified name any time you refer to a 97 | class, function or type. 98 | 99 | The next line: 100 | 101 | ```yaml 102 | forward_declare: true 103 | ``` 104 | 105 | will arrange to declare (but not define) the class for you. This 106 | means that we can take less care in writing the package include 107 | file (`inst/include/examples.h`). In particular, all RcppR6 code 108 | (both `examples/RcppR6_pre.hpp` and `examples/RcppR6_post.hpp`, 109 | along with `Rcpp.h`) can be included before you include 110 | `inst/examples/uniform.hpp` because the class will have been 111 | forward declared. That's in contrast with the introduction where 112 | we defined the entire class before including 113 | `inst/include/RcppR6_pre.h` so that the `as`/`wrap` templates would 114 | work correctly (see "Extending Rcpp"). 115 | 116 | 117 | Next, up, the constructor: 118 | ``` {r echo=FALSE, results="asis"} 119 | yaml <- yaml <- readLines(file.path(path, "inst/uniform.yml")) 120 | i_constructor <- grep("\\s+constructor:", yaml)[[1]] 121 | i_methods <- grep("\\s+methods:", yaml)[[1]] 122 | i_active <- grep("\\s+active:", yaml)[[1]] 123 | yaml_output(yaml[i_constructor:(i_methods - 1)]) 124 | ``` 125 | 126 | The first argument here, `roxygen` defines some roxygen content to 127 | include in the generated `R/RcppR6.R` file, but without the leading 128 | `#'`. This will generate a very minimal set of documentation with 129 | the title, parameters (`min` and `max`) and arrange to `@export` 130 | the object so it appears in the package `NAMESPACE`. Use of this 131 | field is optional, and will generally require yaml's pipe syntax to 132 | indicate whitespace should be retained in the multiline string. 133 | 134 | The `args` field is a yaml ordered map of two arguments. Both are 135 | `double`s, and both have default values that will be added to the 136 | generated R code: 137 | 138 | ```r 139 | uniform <- function(min=0.0, max=1.0) { ... } 140 | ``` 141 | 142 | There are two methods `draw` and `range`: 143 | ``` {r echo=FALSE, results="asis"} 144 | yaml_output(yaml[i_methods:(i_active - 1)]) 145 | ``` 146 | 147 | The `draw` method takes a single integer and returns a 148 | `Rcpp::NumericVector`. Because no `name_cpp` is given, RcppR6 will 149 | assume that there is a method `draw` within the class that can be 150 | used. And because no `access` is given RcppR6 assumes that `draw` 151 | is a method and not a free function. 152 | 153 | The `range` method calls the free function 154 | `examples::uniform_range()`. The C++ function takes the argument 155 | `const Uniform& w` but this argument is *not* referred to in the 156 | yaml (the first argument of a free function must take a reference 157 | to the object). We have to tell RcppR6 that the function is free 158 | (rather than a member) with `access: function` and the name of the 159 | function `name_cpp: examples::uniform_range`. 160 | 161 | 162 | There are a bunch of active methods, because they're a bit more 163 | varied in the options that they can take 164 | ``` {r echo=FALSE, results="asis"} 165 | yaml_output(yaml[i_active:length(yaml)]) 166 | ``` 167 | 168 | First, `min` and `max` are direct field accessors. I've made them 169 | read-only by adding `readonly: true`. Without this (by default) 170 | they would be read-write. You can also use `name_cpp` here to 171 | access a different named field within the C++ class than the name 172 | of the R field that will be generated. 173 | 174 | The field `the_min` *also* accesses the min field, but does so 175 | through the member function `get_min`. The `name_cpp_set` field 176 | indicates the name of the setter (`set_min`). Without providing 177 | this, the field would be read-only. 178 | 179 | The field `the_max` does the same thing as `the_min`, but for the 180 | `max` field and uses a pair of free functions 181 | (`examples::uniform_get_max` and `examples::uniform_set_max`) to 182 | achive this. 183 | 184 | The active field `u` will return a single random number by calling 185 | the function `examples::draw1()`. 186 | 187 | Running RcppR6 (this will create other two classes not yet 188 | discussed) 189 | ``` {r } 190 | RcppR6::install(path) 191 | ``` 192 | 193 | Run `devtools::document` to create the `NAMESPACE` file 194 | ``` {r } 195 | devtools::document(path) 196 | ``` 197 | 198 | And load the package: 199 | ``` {r } 200 | devtools::load_all(path) 201 | ``` 202 | 203 | We can create a `uniform` object: 204 | ``` {r } 205 | u <- uniform() 206 | u 207 | ``` 208 | 209 | Draw 10 random numbers: 210 | ``` {r } 211 | u$draw(10) 212 | ``` 213 | 214 | Or just one: 215 | ``` {r } 216 | u$u 217 | ``` 218 | 219 | The minimum was set to zero and max as one by default: 220 | ``` {r } 221 | u$min 222 | u$max 223 | args(uniform) 224 | ``` 225 | 226 | These are read-only: 227 | ``` {r error=TRUE} 228 | u$min <- 100 229 | u$max <- 200 230 | ``` 231 | 232 | These can be set through the `the_min` and `the_max` fields (which 233 | are totally redundant here and included only for demonstration) 234 | ``` {r } 235 | u$the_min <- 10 236 | u$the_max <- 20 237 | ``` 238 | 239 | new values set: 240 | ``` {r } 241 | u$the_min 242 | u$the_max 243 | ``` 244 | 245 | Random number in new range: 246 | ``` {r } 247 | u$u 248 | ``` 249 | 250 | ## `stack` 251 | 252 | This example shows how to wrap a class that is defined elsewhere -- 253 | `std::stack` in this case. It provides an alternative 254 | implementation to the version in the R6 vignette. 255 | ``` {r echo=FALSE, results="asis"} 256 | cpp_output(readLines(file.path(path, "inst/include/examples/stack.hpp"))) 257 | ``` 258 | 259 | The comments in the C++ code explain largely what is going on; 260 | there are safe wrappers around `pop` and `top` that prevent 261 | crashes. Better behavour for `top` on an empty stack might be to 262 | throw an error (though that will cause problems as an active member 263 | with R6 < 2.0.0.9000, which includes the current version on CRAN - 264 | 2.0.0 at the time of writing). 265 | 266 | Then yaml that goes along with this: 267 | ``` {r echo=FALSE, results="asis"} 268 | yaml_output(readLines(file.path(path, "inst/stack.yml"))) 269 | ``` 270 | 271 | There's not that much more here than for `uniform`: 272 | 273 | * `differs` shows how to wrap an operator (though turning this into 274 | something that dispatches nicely on the R side will take [more 275 | work](https://github.com/wch/s3ops) 276 | * the class was defined elsewhere as a templated library function 277 | but we can still wrap it easily enough. 278 | 279 | ``` {r } 280 | s <- stack() 281 | ``` 282 | 283 | Empty stack has a missing top: 284 | ``` {r } 285 | s$top 286 | ``` 287 | 288 | and throws an error when popped (and does not crash!) 289 | ``` {r error=TRUE} 290 | s$pop() 291 | ``` 292 | 293 | Push some numbers on the stack: 294 | ``` {r } 295 | s$push(1) 296 | s$push(10) 297 | s$push(100) 298 | ``` 299 | 300 | Three things on the stack: 301 | ``` {r } 302 | s$size 303 | ``` 304 | 305 | First one is: 306 | ``` {r } 307 | s$top 308 | ``` 309 | 310 | `std::stack` does not return on `pop`, unlike Python's stack 311 | ``` {r } 312 | s$pop() 313 | 314 | s$top 315 | ``` 316 | 317 | empty out the stack by popping repeatedly: 318 | ``` {r } 319 | while (!s$empty) { 320 | s$pop() 321 | } 322 | s$size 323 | ``` 324 | 325 | ## `empty` 326 | 327 | `empty` is the *simplest posssible* RcppR6 class, defined within 328 | the `simple.hpp` header file: 329 | 330 | ``` {r echo=FALSE, results="asis"} 331 | cpp_output(readLines(file.path(path, "inst/include/examples/empty.hpp"))) 332 | ``` 333 | 334 | This class defines no methods, no constructors, no fields. It is 335 | totally useless. But we can still wrap it up. 336 | ``` {r echo=FALSE, results="asis"} 337 | yaml_output(readLines(file.path(path, "inst/empty.yml"))) 338 | ``` 339 | 340 | This probably serves no benefit at all. 341 | ``` {r } 342 | e <- empty() 343 | e 344 | ``` 345 | -------------------------------------------------------------------------------- /vignettes/introduction.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Introduction to RcppR6" 3 | author: "Rich FitzJohn" 4 | date: "`r Sys.Date()`" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{Introduction to RcppR6} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | %\VignetteEncoding{UTF-8} 10 | --- 11 | 12 | RcppR6 is a code generation approach for exposing C++ classes as R 13 | classes. It makes it possible to define a class in C++ and expose 14 | it in R as an [R6](https://github.com/wch/R6) class, with reference 15 | semantics for the class on the R side. 16 | 17 | This first example walks through setting up the example used in the 18 | package [README](https://github.com/richfitz/RcppR6). This example 19 | creates a simple "circle" class to show a few features of the 20 | package. 21 | 22 | ``` {r echo=FALSE} 23 | set.seed(1) 24 | source(system.file("vignette_common.R", package="RcppR6")) 25 | path <- vignette_prepare("introduction") 26 | ``` 27 | 28 | ``` {r echo=FALSE, results="asis"} 29 | cls <- readLines(file.path(path, "inst/include/introduction.h")) 30 | i1 <- grep("^#include", cls)[[1]] 31 | i2 <- grep("^};", cls)[[1]] 32 | cpp_output(cls[i1:i2]) 33 | ``` 34 | 35 | What we want is some way if exposing this class to R so that we 36 | could interact with the methods directly. The usual approach with 37 | annotating with 38 | ``` 39 | // [[Rcpp::export]] 40 | ``` 41 | won't work here because that only wraps free functions; we need a 42 | way to generate these free functions and to organise getting an 43 | object that will keep the state of the class (here, the `radius` 44 | field). 45 | 46 | RcppR6 currently requires working in a package structure: this is 47 | encouraged in the [Rcpp intro](TODO:LINK) anyway. Eventually it 48 | might support inline use, but that is not currently supported. 49 | 50 | RcppR6 also requires a particular structure to a package (this 51 | might change!) because it needs to be able to `#include` all the 52 | class definitions in ways that plain Rcpp attributes don't need. 53 | 54 | The code used here is a demo package called `introduction`, available 55 | within RcppR6 (`system.file("examples/introduction", package="RcppR6")`) 56 | It's a purposely minimal (and frankly, silly) package that includes 57 | only a few files to start; this is the minimal set of files to use 58 | RcppR6: 59 | 60 | ``` {r echo=FALSE, results="asis"} 61 | tree <- function(path, header=path) { 62 | paste1 <- function(a, b) { 63 | paste(rep_len(a, length(b)), b) 64 | } 65 | indent <- function(x, files) { 66 | paste0(if (files) "| " else " ", x) 67 | } 68 | is_directory <- function(x) { 69 | unname(file.info(x)[, "isdir"]) 70 | } 71 | prefix_file <- "|--=" 72 | prefix_dir <- "|-+=" 73 | 74 | files <- dir(path) 75 | files_full <- file.path(path, files) 76 | isdir <- is_directory(files_full) 77 | 78 | ret <- as.list(c(paste1(prefix_dir, files[isdir]), 79 | paste1(prefix_file, files[!isdir]))) 80 | files_full <- c(files_full[isdir], files_full[!isdir]) 81 | isdir <- c(isdir[isdir], isdir[!isdir]) 82 | 83 | n <- length(ret) 84 | ret[[n]] <- sub("|", "\\", ret[[n]], fixed=TRUE) 85 | tmp <- lapply(which(isdir), function(i) 86 | c(ret[[i]], indent(tree(files_full[[i]], NULL), !all(isdir)))) 87 | ret[isdir] <- tmp 88 | 89 | c(header, unlist(ret)) 90 | } 91 | plain_output(tree(path, "introduction")) 92 | ``` 93 | 94 | A file `.h` is required within `inst/include`; this 95 | file must include *all* class definitions that RcppR6 is to wrap. 96 | So for this package `introduction`, the above definition is included 97 | within the file `inst/include/introduction.h` 98 | 99 | The main work is in the file `inst/RcppR6_classes.yml` this is a 100 | [yaml](http:/yaml.org) file containing key/value pairs indicating 101 | how to export the class. 102 | ``` {r echo=FALSE, results="asis"} 103 | yaml <- readLines(file.path(path, "inst/RcppR6_classes.yml")) 104 | yaml_output(yaml) 105 | ``` 106 | 107 | This is the main file that needs editing to organise export of the 108 | class. Compared with Rcpp modules it contains a lot of type 109 | information that could have been lifted from the class definition, 110 | but future versions may remove this limitation. 111 | 112 | The yaml is hopefully fairly self-explanatory, and illustrates 113 | *almost* all of the features needed features. Below, I'll walk 114 | through each section in turn: the constructor, the method, and then 115 | the "active" fields. 116 | 117 | First, a **constructor**; this is the function that creates the 118 | object. 119 | 120 | ``` {r echo=FALSE, results="asis"} 121 | i_constructor <- grep("\\s+constructor:", yaml)[[1]] 122 | i_methods <- grep("\\s+methods:", yaml)[[1]] 123 | i_active <- grep("\\s+active:", yaml)[[1]] 124 | yaml_output(yaml[i_constructor:(i_methods - 1)]) 125 | ``` 126 | 127 | The `args` element is a yaml ordered map (by definition a map in 128 | yaml is not ordered, but ordering is critical here). Each pair in 129 | the args is of the form: `: `, so this just says that 130 | there is one argument, `radius`, which has type `double`. Note 131 | that the name need not match up with the name in the C++ class (and 132 | does not here) but the name must be valid in *both* R and C++. 133 | That means no dots are allowed. 134 | 135 | If the type contains colons (e.g., `std::string`) it will probably 136 | be required to enclose the type in double quotes or the yaml parser 137 | will throw an error. 138 | 139 | An alternative way of writing the arguments using an ordered map in 140 | yaml is: 141 | 142 | ```yaml 143 | args: 144 | - {radius: double} 145 | ``` 146 | 147 | with additional arguments as additional list elements (`-`). 148 | 149 | By default (and above) this will use the constructor of the C++ 150 | class, but it is possible to specify a free function that returns 151 | an object of class `circle`. So if you had: 152 | 153 | ```c++ 154 | circle make_circle(double radius) { 155 | return circle(radius); 156 | } 157 | ``` 158 | 159 | you could use that by writing: 160 | 161 | ```yaml 162 | constructor: 163 | name_cpp: make_circle 164 | args: ... # as above 165 | ``` 166 | 167 | In the generated object, a function with the name of the class will 168 | be generated (so `circle`) taking the one argument `radius`. (Note 169 | that this differs from the usual way that R6 objects are 170 | generated). 171 | 172 | ```r 173 | circle(1.0) # would create a circle with radius 1.0 174 | ``` 175 | 176 | Next, one **method** is defined in the yaml: 177 | ``` {r echo=FALSE, results="asis"} 178 | yaml_output(yaml[i_methods:(i_active - 1)]) 179 | ``` 180 | 181 | The `methods` field contains any number of methods; here, only the 182 | method `area` is defined. 183 | 184 | Each method may contain an `args` element (as the constructor did) 185 | but here it is omitted because the function has no arguments. 186 | 187 | The field `return_type` is required; here the method is going to 188 | return a `double`. 189 | 190 | If `x` is a circle object, created by the constructor `circle` 191 | above, then the method would be used by writing: 192 | 193 | ```r 194 | r$area() 195 | ``` 196 | 197 | Instead of using class methods, RcppR6 can also use functions that 198 | take references to objects and turn these into methods in the 199 | generated object. So if we had a function: 200 | 201 | ```c++ 202 | double circle_area(const circle& x) { 203 | return x.area(); 204 | } 205 | ``` 206 | 207 | that could be specified above by writing: 208 | 209 | ```yaml 210 | area: 211 | return_type: double 212 | access: function 213 | name_cpp: circle_area 214 | ``` 215 | 216 | The field `access` takes values "member" (the default, indicating a 217 | member function) or `function`, indicating a free function. The 218 | field `name_cpp` is the name of the function (or member) in C++. 219 | The actual name `area` will be used in the generated object. 220 | 221 | Finally, two **active fields** are specified; `circumference` and 222 | `radius`: 223 | ``` {r echo=FALSE, results="asis"} 224 | yaml_output(yaml[i_active:length(yaml)]) 225 | ``` 226 | 227 | The first, `circumference` provides both setters and getters 228 | (`name_cpp` and `name_cpp_set`, respectively). The getter could be 229 | ommited here because it shares the same name as the R name for the 230 | field. 231 | 232 | Getters must be a function that takes no arguments and return a 233 | thing that they get, while setters must take a single thing and 234 | return void. It's probably a good idea for a getter to be a const 235 | method (see the C++ definition of `circumference` above), but 236 | that's not enforced. A setter can do whatever argument checking it 237 | wants. 238 | 239 | "active" members also require a `type` entry: this is the return 240 | type for the getter and the argument type for the setter. 241 | 242 | The `circumference` field has access "member"; this means it is 243 | accessed by member functions). The other alternatives are 244 | "function" (as for the "methods" section above) and `field`. 245 | 246 | The `radius` active member has access `field`: it means that the 247 | field is accesed directly, with no argument checking. By default 248 | this is a read-write binding, but by specifying `readonly: true`, 249 | this can be made read-only. Note here that a shorthand `{...}` 250 | notation is used - this is equivalent yaml to: 251 | ``` {r echo=FALSE, results="asis"} 252 | dat <- RcppR6:::yaml_load(paste(yaml, collapse="\n")) 253 | yaml_output(yaml::as.yaml(dat$circle$active["radius"])) 254 | ``` 255 | 256 | That's almost all the bits: there are a few other required bits for 257 | the package header: 258 | ``` {r echo=FALSE, results="asis"} 259 | tmp <- grep("^//", cls, value=TRUE, invert=TRUE) 260 | cpp_output(gsub("\n\n+", "\n\n", paste(tmp, collapse="\n"))) 261 | ``` 262 | 263 | In addition to the class defnition above, there are a few extra 264 | bits: 265 | 266 | * header guards (optional, but probably going to be needed) 267 | * including the file `` 268 | - this will be added to the `inst/include/introduction` directory when 269 | running RcppR6; it contains prototypes for the `as` and `wrap` 270 | functions required to export types from C++ to R (see the 271 | "extending Rcpp" vignette). 272 | - this needs to be included after your classes have been 273 | *declared*, but may be included before your classes have been 274 | *defined*. It must be included *after* `` and 275 | *before* ``. 276 | * including the file ` 277 | - this will include the definition of the `as` and `wrap` 278 | functions, as well as `` (if it hasn't already been 279 | included) and some support code needed by RcppR6. 280 | 281 | The `DESCRIPTION` file contains nothing special: 282 | ``` {r echo=FALSE, results="asis"} 283 | plain_output(readLines(file.path(path, "DESCRIPTION"))) 284 | ``` 285 | 286 | and the NAMESPACE file is empty. 287 | 288 | With everything in place, let's go: 289 | ``` {r } 290 | RcppR6::install(path) 291 | ``` 292 | 293 | Quite a few files have been added, and some of the existing files 294 | have been updated 295 | ``` {r echo=FALSE, results="asis"} 296 | plain_output(tree(path, "introduction")) 297 | ``` 298 | 299 | RcppR6 reads the DESCRIPTION and adds the required packages: the 300 | package must import Rcpp and R6, and must include Rcpp in 301 | `LinkingTo:`. Note that RcppR6 *does not appear anywhere* in the 302 | description: once RcppR6 has generated code, it is done and is not 303 | a dependency. 304 | ``` {r echo=FALSE, results="asis"} 305 | plain_output(readLines(file.path(path, "DESCRIPTION"))) 306 | ``` 307 | 308 | Because `src/Makevars` was missing originally, it has been creted 309 | with contents: 310 | ``` {r echo=FALSE, results="asis"} 311 | plain_output(readLines(file.path(path, "src/Makevars"))) 312 | ``` 313 | 314 | (if it already existed it would have been left alone and you would 315 | have to add this yourself). 316 | 317 | The other files: `inst/include/introduction/RcppR6_pre.hpp`, 318 | `inst/include/introduction/RcppR6_post.hpp`, 319 | `inst/include/introduction/RcppR6_support.hpp`, `R/RcppR6.R` and 320 | `src/RcppR6.R` contain boilerplate glue code, and the files 321 | `R/RcppExports.R` and `src/RcppExports.cpp` contain the usual Rcpp 322 | attributes generated code to support them. See the bottom of this 323 | file for what is generated, if you are curious. 324 | 325 | The package can now be compiled. I'm using `devtools::document` 326 | here because the generated code includes enough roxygen hints to 327 | generate a minimal `NAMESPACE` file: 328 | ``` {r } 329 | devtools::document(path) 330 | ``` 331 | 332 | The package can now be loaded: 333 | ``` {r } 334 | devtools::load_all(path) 335 | ``` 336 | 337 | and a circle object can be created: 338 | ``` {r } 339 | obj <- circle(1.0) 340 | obj 341 | ``` 342 | 343 | This object has class `r class(obj)[[1]]`: 344 | ``` {r } 345 | class(obj) 346 | ``` 347 | 348 | There's a data member `.ptr` 349 | ``` {r } 350 | obj$.ptr 351 | ``` 352 | 353 | This is the actual external pointer object that holds a reference 354 | to the underlying C++ class instance. It is not designed to be 355 | interacted with directly. The `initialize` method is also not 356 | meant to be used directly: 357 | ``` {r } 358 | obj$initialize 359 | ``` 360 | 361 | (this is used by the support code and why the objects are not 362 | created with the usual R6 `circle$new()` syntax). 363 | 364 | The one method and two active binding members are present in the 365 | class: `area`, `circumference` and `radius`. 366 | 367 | The area of a circle of radius 1 is of course pi 368 | ``` {r } 369 | obj$area() 370 | obj$area() - pi 371 | ``` 372 | 373 | Because the radius is an active member, parentheses are not needed 374 | to access it: 375 | ``` {r } 376 | obj$radius 377 | ``` 378 | 379 | and it can be set as if it were a field: 380 | ``` {r } 381 | obj$radius <- 2 382 | obj$radius 383 | obj$area() 384 | ``` 385 | 386 | Similarly, the circumference can be set, routing through the 387 | `set_circumference` function that converts to a radius: 388 | ``` {r } 389 | obj$circumference <- 1.0 390 | obj$circumference 391 | obj$radius 392 | ``` 393 | 394 | and because that function has error checking in it, you can't set 395 | negative values: 396 | ``` {r error=TRUE} 397 | obj$circumference <- -1 398 | ``` 399 | 400 | Once set up, RcppR6 should be relatively cheap to run as it detects 401 | that nothing has changed: 402 | ``` {r } 403 | system.time(RcppR6::RcppR6(path)) 404 | ``` 405 | 406 | # Contents of generated files: 407 | 408 | `inst/include/introduction/RcppR6_pre.hpp`: 409 | ``` {r echo=FALSE, results="asis"} 410 | cpp_output(readLines(file.path(path, "inst/include/introduction/RcppR6_pre.hpp"))) 411 | ``` 412 | 413 | `inst/include/introduction/RcppR6_post.hpp`: 414 | ``` {r echo=FALSE, results="asis"} 415 | cpp_output(readLines(file.path(path, "inst/include/introduction/RcppR6_post.hpp"))) 416 | ``` 417 | 418 | `inst/include/introduction/RcppR6_support.hpp`: 419 | ``` {r echo=FALSE, results="asis"} 420 | cpp_output(readLines(file.path(path, "inst/include/introduction/RcppR6_support.hpp"))) 421 | ``` 422 | 423 | `R/RcppR6.R`: 424 | ``` {r echo=FALSE, results="asis"} 425 | r_output(readLines(file.path(path, "R/RcppR6.R"))) 426 | ``` 427 | 428 | `R/RcppR6.R`: 429 | ``` {r echo=FALSE, results="asis"} 430 | cpp_output(readLines(file.path(path, "src/RcppR6.cpp"))) 431 | ``` 432 | -------------------------------------------------------------------------------- /vignettes/src/examples.R: -------------------------------------------------------------------------------- 1 | ## --- 2 | ## title: "RcppR6 examples" 3 | ## author: "Rich FitzJohn" 4 | ## date: "`r Sys.Date()`" 5 | ## output: rmarkdown::html_vignette 6 | ## vignette: > 7 | ## %\VignetteIndexEntry{RcppR6 examples} 8 | ## %\VignetteEngine{knitr::rmarkdown} 9 | ## %\VignetteEncoding{UTF-8} 10 | ## --- 11 | 12 | ## This vignette builds on the introduction one to provide a 13 | ## marginally more useful example, and demonstrate a few more features 14 | ## of RcppR6. 15 | 16 | ## The code used here is a demo package called `examples`, available 17 | ## within RcppR6 (`system.file("examples/examples", 18 | ## package="RcppR6")`), and like the `introduction` package doesn't 19 | ## really do anything that you'd really want to do, or need RcppR6 to 20 | ## do. 21 | 22 | ##+ echo=FALSE, results="asis" 23 | set.seed(1) 24 | source(system.file("vignette_common.R", package="RcppR6")) 25 | path <- vignette_prepare("examples") 26 | plain_output(tree(path, "introduction")) 27 | 28 | ## This package defines three classes, of varying complexity. It uses 29 | ## a different way of structuring sources to `introduction`; 30 | 31 | ##+ echo=FALSE, results="asis" 32 | yaml_output(readLines(file.path(path, "inst/RcppR6.yml"))) 33 | 34 | ## Rather than a single file `inst/RcppR6_classes.yml`, there is a 35 | ## file `inst/RcppR6.yml` that lists files to include, relative to the 36 | ## package root. This isn't necessary, but might help with 37 | ## organisation. Each file can define one or more classes -- here 38 | ## they define a single class each. 39 | 40 | ## Similarly, the definitions are spread over three files: 41 | ## `inst/include/examples/uniform.hpp`, 42 | ## `inst/include/examples/stack.hpp` and 43 | ## `inst/include/examples/empty.hpp`. 44 | 45 | ## ## `uniform` 46 | 47 | ## This is a similar example to the Rcpp modules example of a uniform 48 | ## distribution object. It's not identical to the modules version. 49 | ##+ echo=FALSE, results="asis" 50 | cpp_output(readLines(file.path(path, "inst/include/examples/uniform.hpp"))) 51 | 52 | ## The `Rcpp::RNGScope` bit is probably not needed, actually as Rcpp 53 | ## attributes will sort that out for us. 54 | 55 | ## The example is declared with a namespace `examples`; unlike 56 | ## attributes, RcppR6 does not have a problem exporting things that 57 | ## are not in the global namespace. This comes in useful for wrapping 58 | ## library code. 59 | 60 | ## In addition to the class definition, there are also some free 61 | ## functions defined; `uniform_get_max` and `uniform_set_max`; these 62 | ## are going to be used to set up active members in the R6 class for 63 | ## getting and setting the `max` field of the class. This pattern 64 | ## (free functions) is useful if you want to do additional error 65 | ## checking on inputs when calling from R than when calling from C++ 66 | ## (e.g., passing an `int` into a function that expects an unsigned 67 | ## integer). 68 | 69 | ## Note that the getter takes first argument of type `const Uniform&`; 70 | ## a const reference to a `Uniform` object. A non-const reference 71 | ## would be fine here, as would a *copy* of the object. The setter 72 | ## takes first argument `Uniform&`; this needs to be a reference (and 73 | ## not a pointer). Passing in a copy here will *appear* to work (as 74 | ## in; will compile and run) but will not change the value. 75 | 76 | ## The `yaml` for this: 77 | ##+ echo=FALSE, results="asis" 78 | yaml_output(readLines(file.path(path, "inst/uniform.yml"))) 79 | 80 | ## In order: 81 | ## 82 | ## ```yaml 83 | ## uniform: 84 | ## name_cpp: examples::Uniform 85 | ## ``` 86 | ## 87 | ## This means that the name of the class on the R side will be 88 | ## *different* to the name on the C++ side. We'll export the class as 89 | ## `uniform` (so that `uniform(...)` will be the constructor in R) but 90 | ## that the actuall class we are wrapping is called 91 | ## `examples::Uniform`. This is how RcppR6 deals with namespaces -- 92 | ## just provide the fully qualified name any time you refer to a 93 | ## class, function or type. 94 | 95 | ## The next line: 96 | ## 97 | ## ```yaml 98 | ## forward_declare: true 99 | ## ``` 100 | ## 101 | ## will arrange to declare (but not define) the class for you. This 102 | ## means that we can take less care in writing the package include 103 | ## file (`inst/include/examples.h`). In particular, all RcppR6 code 104 | ## (both `examples/RcppR6_pre.hpp` and `examples/RcppR6_post.hpp`, 105 | ## along with `Rcpp.h`) can be included before you include 106 | ## `inst/examples/uniform.hpp` because the class will have been 107 | ## forward declared. That's in contrast with the introduction where 108 | ## we defined the entire class before including 109 | ## `inst/include/RcppR6_pre.h` so that the `as`/`wrap` templates would 110 | ## work correctly (see "Extending Rcpp"). 111 | 112 | 113 | ## Next, up, the constructor: 114 | ##+ echo=FALSE, results="asis" 115 | yaml <- yaml <- readLines(file.path(path, "inst/uniform.yml")) 116 | i_constructor <- grep("\\s+constructor:", yaml)[[1]] 117 | i_methods <- grep("\\s+methods:", yaml)[[1]] 118 | i_active <- grep("\\s+active:", yaml)[[1]] 119 | yaml_output(yaml[i_constructor:(i_methods - 1)]) 120 | 121 | ## The first argument here, `roxygen` defines some roxygen content to 122 | ## include in the generated `R/RcppR6.R` file, but without the leading 123 | ## `#'`. This will generate a very minimal set of documentation with 124 | ## the title, parameters (`min` and `max`) and arrange to `@export` 125 | ## the object so it appears in the package `NAMESPACE`. Use of this 126 | ## field is optional, and will generally require yaml's pipe syntax to 127 | ## indicate whitespace should be retained in the multiline string. 128 | 129 | ## The `args` field is a yaml ordered map of two arguments. Both are 130 | ## `double`s, and both have default values that will be added to the 131 | ## generated R code: 132 | ## 133 | ## ```r 134 | ## uniform <- function(min=0.0, max=1.0) { ... } 135 | ## ``` 136 | 137 | ## There are two methods `draw` and `range`: 138 | ##+ echo=FALSE, results="asis" 139 | yaml_output(yaml[i_methods:(i_active - 1)]) 140 | 141 | ## The `draw` method takes a single integer and returns a 142 | ## `Rcpp::NumericVector`. Because no `name_cpp` is given, RcppR6 will 143 | ## assume that there is a method `draw` within the class that can be 144 | ## used. And because no `access` is given RcppR6 assumes that `draw` 145 | ## is a method and not a free function. 146 | 147 | ## The `range` method calls the free function 148 | ## `examples::uniform_range()`. The C++ function takes the argument 149 | ## `const Uniform& w` but this argument is *not* referred to in the 150 | ## yaml (the first argument of a free function must take a reference 151 | ## to the object). We have to tell RcppR6 that the function is free 152 | ## (rather than a member) with `access: function` and the name of the 153 | ## function `name_cpp: examples::uniform_range`. 154 | 155 | 156 | ## There are a bunch of active methods, because they're a bit more 157 | ## varied in the options that they can take 158 | ##+ echo=FALSE, results="asis" 159 | yaml_output(yaml[i_active:length(yaml)]) 160 | 161 | ## First, `min` and `max` are direct field accessors. I've made them 162 | ## read-only by adding `readonly: true`. Without this (by default) 163 | ## they would be read-write. You can also use `name_cpp` here to 164 | ## access a different named field within the C++ class than the name 165 | ## of the R field that will be generated. 166 | 167 | ## The field `the_min` *also* accesses the min field, but does so 168 | ## through the member function `get_min`. The `name_cpp_set` field 169 | ## indicates the name of the setter (`set_min`). Without providing 170 | ## this, the field would be read-only. 171 | 172 | ## The field `the_max` does the same thing as `the_min`, but for the 173 | ## `max` field and uses a pair of free functions 174 | ## (`examples::uniform_get_max` and `examples::uniform_set_max`) to 175 | ## achive this. 176 | 177 | ## The active field `u` will return a single random number by calling 178 | ## the function `examples::draw1()`. 179 | 180 | ## Running RcppR6 (this will create other two classes not yet 181 | ## discussed) 182 | RcppR6::install(path) 183 | 184 | ## Run `devtools::document` to create the `NAMESPACE` file 185 | devtools::document(path) 186 | 187 | ## And load the package: 188 | devtools::load_all(path) 189 | 190 | ## We can create a `uniform` object: 191 | u <- uniform() 192 | u 193 | 194 | ## Draw 10 random numbers: 195 | u$draw(10) 196 | 197 | ## Or just one: 198 | u$u 199 | 200 | ## The minimum was set to zero and max as one by default: 201 | u$min 202 | u$max 203 | args(uniform) 204 | 205 | ## These are read-only: 206 | ##+ error=TRUE 207 | u$min <- 100 208 | u$max <- 200 209 | 210 | ## These can be set through the `the_min` and `the_max` fields (which 211 | ## are totally redundant here and included only for demonstration) 212 | u$the_min <- 10 213 | u$the_max <- 20 214 | 215 | ## new values set: 216 | u$the_min 217 | u$the_max 218 | 219 | ## Random number in new range: 220 | u$u 221 | 222 | ## ## `stack` 223 | 224 | ## This example shows how to wrap a class that is defined elsewhere -- 225 | ## `std::stack` in this case. It provides an alternative 226 | ## implementation to the version in the R6 vignette. 227 | ##+ echo=FALSE, results="asis" 228 | cpp_output(readLines(file.path(path, "inst/include/examples/stack.hpp"))) 229 | 230 | ## The comments in the C++ code explain largely what is going on; 231 | ## there are safe wrappers around `pop` and `top` that prevent 232 | ## crashes. Better behavour for `top` on an empty stack might be to 233 | ## throw an error (though that will cause problems as an active member 234 | ## with R6 < 2.0.0.9000, which includes the current version on CRAN - 235 | ## 2.0.0 at the time of writing). 236 | 237 | ## Then yaml that goes along with this: 238 | ##+ echo=FALSE, results="asis" 239 | yaml_output(readLines(file.path(path, "inst/stack.yml"))) 240 | 241 | ## There's not that much more here than for `uniform`: 242 | ## 243 | ## * `differs` shows how to wrap an operator (though turning this into 244 | ## something that dispatches nicely on the R side will take [more 245 | ## work](https://github.com/wch/s3ops) 246 | ## * the class was defined elsewhere as a templated library function 247 | ## but we can still wrap it easily enough. 248 | 249 | s <- stack() 250 | 251 | ## Empty stack has a missing top: 252 | s$top 253 | 254 | ## and throws an error when popped (and does not crash!) 255 | ##+ error=TRUE 256 | s$pop() 257 | 258 | ## Push some numbers on the stack: 259 | s$push(1) 260 | s$push(10) 261 | s$push(100) 262 | 263 | ## Three things on the stack: 264 | s$size 265 | 266 | ## First one is: 267 | s$top 268 | 269 | ## `std::stack` does not return on `pop`, unlike Python's stack 270 | s$pop() 271 | 272 | s$top 273 | 274 | ## empty out the stack by popping repeatedly: 275 | while (!s$empty) { 276 | s$pop() 277 | } 278 | s$size 279 | 280 | ## ## `empty` 281 | 282 | ## `empty` is the *simplest posssible* RcppR6 class, defined within 283 | ## the `simple.hpp` header file: 284 | 285 | ##+ echo=FALSE, results="asis" 286 | cpp_output(readLines(file.path(path, "inst/include/examples/empty.hpp"))) 287 | 288 | ## This class defines no methods, no constructors, no fields. It is 289 | ## totally useless. But we can still wrap it up. 290 | ##+ echo=FALSE, results="asis" 291 | yaml_output(readLines(file.path(path, "inst/empty.yml"))) 292 | 293 | ## This probably serves no benefit at all. 294 | e <- empty() 295 | e 296 | -------------------------------------------------------------------------------- /vignettes/src/introduction.R: -------------------------------------------------------------------------------- 1 | ## --- 2 | ## title: "Introduction to RcppR6" 3 | ## author: "Rich FitzJohn" 4 | ## date: "`r Sys.Date()`" 5 | ## output: rmarkdown::html_vignette 6 | ## vignette: > 7 | ## %\VignetteIndexEntry{Introduction to RcppR6} 8 | ## %\VignetteEngine{knitr::rmarkdown} 9 | ## %\VignetteEncoding{UTF-8} 10 | ## --- 11 | 12 | ## RcppR6 is a code generation approach for exposing C++ classes as R 13 | ## classes. It makes it possible to define a class in C++ and expose 14 | ## it in R as an [R6](https://github.com/wch/R6) class, with reference 15 | ## semantics for the class on the R side. 16 | 17 | ## This first example walks through setting up the example used in the 18 | ## package [README](https://github.com/richfitz/RcppR6). This example 19 | ## creates a simple "circle" class to show a few features of the 20 | ## package. 21 | 22 | ##+ echo=FALSE 23 | set.seed(1) 24 | source(system.file("vignette_common.R", package="RcppR6")) 25 | path <- vignette_prepare("introduction") 26 | 27 | ### Here, I only want to include the core of the class definition, and 28 | ### don't want the distracting Emacs bits or the header guard: 29 | ##+ echo=FALSE, results="asis" 30 | cls <- readLines(file.path(path, "inst/include/introduction.h")) 31 | i1 <- grep("^#include", cls)[[1]] 32 | i2 <- grep("^};", cls)[[1]] 33 | cpp_output(cls[i1:i2]) 34 | 35 | ## What we want is some way if exposing this class to R so that we 36 | ## could interact with the methods directly. The usual approach with 37 | ## annotating with 38 | ## ``` 39 | ## // [[Rcpp::export]] 40 | ## ``` 41 | ## won't work here because that only wraps free functions; we need a 42 | ## way to generate these free functions and to organise getting an 43 | ## object that will keep the state of the class (here, the `radius` 44 | ## field). 45 | 46 | ## RcppR6 currently requires working in a package structure: this is 47 | ## encouraged in the [Rcpp intro](TODO:LINK) anyway. Eventually it 48 | ## might support inline use, but that is not currently supported. 49 | 50 | ## RcppR6 also requires a particular structure to a package (this 51 | ## might change!) because it needs to be able to `#include` all the 52 | ## class definitions in ways that plain Rcpp attributes don't need. 53 | 54 | ## The code used here is a demo package called `introduction`, available 55 | ## within RcppR6 (`system.file("examples/introduction", package="RcppR6")`) 56 | ## It's a purposely minimal (and frankly, silly) package that includes 57 | ## only a few files to start; this is the minimal set of files to use 58 | ## RcppR6: 59 | 60 | ##+ echo=FALSE, results="asis" 61 | tree <- function(path, header=path) { 62 | paste1 <- function(a, b) { 63 | paste(rep_len(a, length(b)), b) 64 | } 65 | indent <- function(x, files) { 66 | paste0(if (files) "| " else " ", x) 67 | } 68 | is_directory <- function(x) { 69 | unname(file.info(x)[, "isdir"]) 70 | } 71 | prefix_file <- "|--=" 72 | prefix_dir <- "|-+=" 73 | 74 | files <- dir(path) 75 | files_full <- file.path(path, files) 76 | isdir <- is_directory(files_full) 77 | 78 | ret <- as.list(c(paste1(prefix_dir, files[isdir]), 79 | paste1(prefix_file, files[!isdir]))) 80 | files_full <- c(files_full[isdir], files_full[!isdir]) 81 | isdir <- c(isdir[isdir], isdir[!isdir]) 82 | 83 | n <- length(ret) 84 | ret[[n]] <- sub("|", "\\", ret[[n]], fixed=TRUE) 85 | tmp <- lapply(which(isdir), function(i) 86 | c(ret[[i]], indent(tree(files_full[[i]], NULL), !all(isdir)))) 87 | ret[isdir] <- tmp 88 | 89 | c(header, unlist(ret)) 90 | } 91 | plain_output(tree(path, "introduction")) 92 | 93 | ## A file `.h` is required within `inst/include`; this 94 | ## file must include *all* class definitions that RcppR6 is to wrap. 95 | ## So for this package `introduction`, the above definition is included 96 | ## within the file `inst/include/introduction.h` 97 | 98 | ## The main work is in the file `inst/RcppR6_classes.yml` this is a 99 | ## [yaml](http:/yaml.org) file containing key/value pairs indicating 100 | ## how to export the class. 101 | ##+ echo=FALSE, results="asis" 102 | yaml <- readLines(file.path(path, "inst/RcppR6_classes.yml")) 103 | yaml_output(yaml) 104 | 105 | ## This is the main file that needs editing to organise export of the 106 | ## class. Compared with Rcpp modules it contains a lot of type 107 | ## information that could have been lifted from the class definition, 108 | ## but future versions may remove this limitation. 109 | 110 | ## The yaml is hopefully fairly self-explanatory, and illustrates 111 | ## *almost* all of the features needed features. Below, I'll walk 112 | ## through each section in turn: the constructor, the method, and then 113 | ## the "active" fields. 114 | 115 | ## First, a **constructor**; this is the function that creates the 116 | ## object. 117 | 118 | ##+ echo=FALSE, results="asis" 119 | i_constructor <- grep("\\s+constructor:", yaml)[[1]] 120 | i_methods <- grep("\\s+methods:", yaml)[[1]] 121 | i_active <- grep("\\s+active:", yaml)[[1]] 122 | yaml_output(yaml[i_constructor:(i_methods - 1)]) 123 | 124 | ## The `args` element is a yaml ordered map (by definition a map in 125 | ## yaml is not ordered, but ordering is critical here). Each pair in 126 | ## the args is of the form: `: `, so this just says that 127 | ## there is one argument, `radius`, which has type `double`. Note 128 | ## that the name need not match up with the name in the C++ class (and 129 | ## does not here) but the name must be valid in *both* R and C++. 130 | ## That means no dots are allowed. 131 | 132 | ## If the type contains colons (e.g., `std::string`) it will probably 133 | ## be required to enclose the type in double quotes or the yaml parser 134 | ## will throw an error. 135 | 136 | ## An alternative way of writing the arguments using an ordered map in 137 | ## yaml is: 138 | ## 139 | ## ```yaml 140 | ## args: 141 | ## - {radius: double} 142 | ## ``` 143 | ## 144 | ## with additional arguments as additional list elements (`-`). 145 | 146 | ## By default (and above) this will use the constructor of the C++ 147 | ## class, but it is possible to specify a free function that returns 148 | ## an object of class `circle`. So if you had: 149 | ## 150 | ## ```c++ 151 | ## circle make_circle(double radius) { 152 | ## return circle(radius); 153 | ## } 154 | ## ``` 155 | ## 156 | ## you could use that by writing: 157 | ## 158 | ## ```yaml 159 | ## constructor: 160 | ## name_cpp: make_circle 161 | ## args: ... # as above 162 | ## ``` 163 | 164 | ## In the generated object, a function with the name of the class will 165 | ## be generated (so `circle`) taking the one argument `radius`. (Note 166 | ## that this differs from the usual way that R6 objects are 167 | ## generated). 168 | 169 | ## ```r 170 | ## circle(1.0) # would create a circle with radius 1.0 171 | ## ``` 172 | 173 | ## Next, one **method** is defined in the yaml: 174 | ##+ echo=FALSE, results="asis" 175 | yaml_output(yaml[i_methods:(i_active - 1)]) 176 | 177 | ## The `methods` field contains any number of methods; here, only the 178 | ## method `area` is defined. 179 | ## 180 | ## Each method may contain an `args` element (as the constructor did) 181 | ## but here it is omitted because the function has no arguments. 182 | ## 183 | ## The field `return_type` is required; here the method is going to 184 | ## return a `double`. 185 | ## 186 | ## If `x` is a circle object, created by the constructor `circle` 187 | ## above, then the method would be used by writing: 188 | ## 189 | ## ```r 190 | ## r$area() 191 | ## ``` 192 | ## 193 | ## Instead of using class methods, RcppR6 can also use functions that 194 | ## take references to objects and turn these into methods in the 195 | ## generated object. So if we had a function: 196 | ## 197 | ## ```c++ 198 | ## double circle_area(const circle& x) { 199 | ## return x.area(); 200 | ## } 201 | ## ``` 202 | ## 203 | ## that could be specified above by writing: 204 | ## 205 | ## ```yaml 206 | ## area: 207 | ## return_type: double 208 | ## access: function 209 | ## name_cpp: circle_area 210 | ## ``` 211 | ## 212 | ## The field `access` takes values "member" (the default, indicating a 213 | ## member function) or `function`, indicating a free function. The 214 | ## field `name_cpp` is the name of the function (or member) in C++. 215 | ## The actual name `area` will be used in the generated object. 216 | 217 | ## Finally, two **active fields** are specified; `circumference` and 218 | ## `radius`: 219 | ##+ echo=FALSE, results="asis" 220 | yaml_output(yaml[i_active:length(yaml)]) 221 | 222 | ## The first, `circumference` provides both setters and getters 223 | ## (`name_cpp` and `name_cpp_set`, respectively). The getter could be 224 | ## ommited here because it shares the same name as the R name for the 225 | ## field. 226 | ## 227 | ## Getters must be a function that takes no arguments and return a 228 | ## thing that they get, while setters must take a single thing and 229 | ## return void. It's probably a good idea for a getter to be a const 230 | ## method (see the C++ definition of `circumference` above), but 231 | ## that's not enforced. A setter can do whatever argument checking it 232 | ## wants. 233 | 234 | ## "active" members also require a `type` entry: this is the return 235 | ## type for the getter and the argument type for the setter. 236 | 237 | ## The `circumference` field has access "member"; this means it is 238 | ## accessed by member functions). The other alternatives are 239 | ## "function" (as for the "methods" section above) and `field`. 240 | 241 | ## The `radius` active member has access `field`: it means that the 242 | ## field is accesed directly, with no argument checking. By default 243 | ## this is a read-write binding, but by specifying `readonly: true`, 244 | ## this can be made read-only. Note here that a shorthand `{...}` 245 | ## notation is used - this is equivalent yaml to: 246 | ##+ echo=FALSE, results="asis" 247 | dat <- RcppR6:::yaml_load(paste(yaml, collapse="\n")) 248 | yaml_output(yaml::as.yaml(dat$circle$active["radius"])) 249 | 250 | ## That's almost all the bits: there are a few other required bits for 251 | ## the package header: 252 | ### Here I'm stripping the comments and bits of excessive whitespace: 253 | ##+ echo=FALSE, results="asis" 254 | tmp <- grep("^//", cls, value=TRUE, invert=TRUE) 255 | cpp_output(gsub("\n\n+", "\n\n", paste(tmp, collapse="\n"))) 256 | 257 | ## In addition to the class defnition above, there are a few extra 258 | ## bits: 259 | ## 260 | ## * header guards (optional, but probably going to be needed) 261 | ## * including the file `` 262 | ## - this will be added to the `inst/include/introduction` directory when 263 | ## running RcppR6; it contains prototypes for the `as` and `wrap` 264 | ## functions required to export types from C++ to R (see the 265 | ## "extending Rcpp" vignette). 266 | ## - this needs to be included after your classes have been 267 | ## *declared*, but may be included before your classes have been 268 | ## *defined*. It must be included *after* `` and 269 | ## *before* ``. 270 | ## * including the file ` 271 | ## - this will include the definition of the `as` and `wrap` 272 | ## functions, as well as `` (if it hasn't already been 273 | ## included) and some support code needed by RcppR6. 274 | 275 | ## The `DESCRIPTION` file contains nothing special: 276 | ##+ echo=FALSE, results="asis" 277 | plain_output(readLines(file.path(path, "DESCRIPTION"))) 278 | 279 | ## and the NAMESPACE file is empty. 280 | 281 | ## With everything in place, let's go: 282 | RcppR6::install(path) 283 | 284 | ## Quite a few files have been added, and some of the existing files 285 | ## have been updated 286 | ##+ echo=FALSE, results="asis" 287 | plain_output(tree(path, "introduction")) 288 | 289 | ## RcppR6 reads the DESCRIPTION and adds the required packages: the 290 | ## package must import Rcpp and R6, and must include Rcpp in 291 | ## `LinkingTo:`. Note that RcppR6 *does not appear anywhere* in the 292 | ## description: once RcppR6 has generated code, it is done and is not 293 | ## a dependency. 294 | ##+ echo=FALSE, results="asis" 295 | plain_output(readLines(file.path(path, "DESCRIPTION"))) 296 | 297 | ## Because `src/Makevars` was missing originally, it has been creted 298 | ## with contents: 299 | ##+ echo=FALSE, results="asis" 300 | plain_output(readLines(file.path(path, "src/Makevars"))) 301 | 302 | ## (if it already existed it would have been left alone and you would 303 | ## have to add this yourself). 304 | 305 | ## The other files: `inst/include/introduction/RcppR6_pre.hpp`, 306 | ## `inst/include/introduction/RcppR6_post.hpp`, 307 | ## `inst/include/introduction/RcppR6_support.hpp`, `R/RcppR6.R` and 308 | ## `src/RcppR6.R` contain boilerplate glue code, and the files 309 | ## `R/RcppExports.R` and `src/RcppExports.cpp` contain the usual Rcpp 310 | ## attributes generated code to support them. See the bottom of this 311 | ## file for what is generated, if you are curious. 312 | 313 | ## The package can now be compiled. I'm using `devtools::document` 314 | ## here because the generated code includes enough roxygen hints to 315 | ## generate a minimal `NAMESPACE` file: 316 | devtools::document(path) 317 | 318 | ## The package can now be loaded: 319 | devtools::load_all(path) 320 | 321 | ## and a circle object can be created: 322 | obj <- circle(1.0) 323 | obj 324 | 325 | ## This object has class `r class(obj)[[1]]`: 326 | class(obj) 327 | 328 | ## There's a data member `.ptr` 329 | obj$.ptr 330 | 331 | ## This is the actual external pointer object that holds a reference 332 | ## to the underlying C++ class instance. It is not designed to be 333 | ## interacted with directly. The `initialize` method is also not 334 | ## meant to be used directly: 335 | obj$initialize 336 | 337 | ## (this is used by the support code and why the objects are not 338 | ## created with the usual R6 `circle$new()` syntax). 339 | 340 | ## The one method and two active binding members are present in the 341 | ## class: `area`, `circumference` and `radius`. 342 | 343 | ## The area of a circle of radius 1 is of course pi 344 | obj$area() 345 | obj$area() - pi 346 | 347 | ## Because the radius is an active member, parentheses are not needed 348 | ## to access it: 349 | obj$radius 350 | 351 | ## and it can be set as if it were a field: 352 | obj$radius <- 2 353 | obj$radius 354 | obj$area() 355 | 356 | ## Similarly, the circumference can be set, routing through the 357 | ## `set_circumference` function that converts to a radius: 358 | obj$circumference <- 1.0 359 | obj$circumference 360 | obj$radius 361 | 362 | ## and because that function has error checking in it, you can't set 363 | ## negative values: 364 | ##+ error=TRUE 365 | obj$circumference <- -1 366 | 367 | ## Once set up, RcppR6 should be relatively cheap to run as it detects 368 | ## that nothing has changed: 369 | system.time(RcppR6::RcppR6(path)) 370 | 371 | ## # Contents of generated files: 372 | 373 | ## `inst/include/introduction/RcppR6_pre.hpp`: 374 | ##+ echo=FALSE, results="asis" 375 | cpp_output(readLines(file.path(path, "inst/include/introduction/RcppR6_pre.hpp"))) 376 | 377 | ## `inst/include/introduction/RcppR6_post.hpp`: 378 | ##+ echo=FALSE, results="asis" 379 | cpp_output(readLines(file.path(path, "inst/include/introduction/RcppR6_post.hpp"))) 380 | 381 | ## `inst/include/introduction/RcppR6_support.hpp`: 382 | ##+ echo=FALSE, results="asis" 383 | cpp_output(readLines(file.path(path, "inst/include/introduction/RcppR6_support.hpp"))) 384 | 385 | ## `R/RcppR6.R`: 386 | ##+ echo=FALSE, results="asis" 387 | r_output(readLines(file.path(path, "R/RcppR6.R"))) 388 | 389 | ## `R/RcppR6.R`: 390 | ##+ echo=FALSE, results="asis" 391 | cpp_output(readLines(file.path(path, "src/RcppR6.cpp"))) 392 | -------------------------------------------------------------------------------- /vignettes/src/templates.R: -------------------------------------------------------------------------------- 1 | ## --- 2 | ## title: "RcppR6 templates" 3 | ## author: "Rich FitzJohn" 4 | ## date: "`r Sys.Date()`" 5 | ## output: rmarkdown::html_vignette 6 | ## vignette: > 7 | ## %\VignetteIndexEntry{RcppR6 templates} 8 | ## %\VignetteEngine{knitr::rmarkdown} 9 | ## %\VignetteEncoding{UTF-8} 10 | ## --- 11 | 12 | ## One of the reasons for writing RcppR6 is for exporting templated 13 | ## classes. I think I have the basics working reasonably well here, 14 | ## but this is definitely an area that might get changed. 15 | 16 | ## The problem is this: if you have some templated type, say 17 | ## ```std::pair```, then you need to write wrappers for all the 18 | ## types `T` and `U` that you need, and arrange for the correct 19 | ## dispatch on the R side. 20 | 21 | ## The way that this is done behind the scenes in RcppR6 is not 22 | ## particularly pretty and might change. 23 | 24 | ## To see how this works, we'll start wrapping `std::pair`. This is 25 | ## just a tuple of data of some type. C++ will need to know the 26 | ## *actual* types. This example is in the `templates` example package. 27 | 28 | ## First, consider the simple case of a pair of the same type. To do 29 | ## this, here's a small class definition (in 30 | ## `inst/include/templates/pair1.hpp`). 31 | ##+ echo=FALSE, results="asis" 32 | set.seed(1) 33 | source(system.file("vignette_common.R", package="RcppR6")) 34 | path <- vignette_prepare("templates") 35 | cpp_output(readLines(file.path(path, "inst/include/templates/pair1.hpp"))) 36 | 37 | ## There's not much going on here: this is just a class that stores 38 | ## two things of the same type. It's fairly compatible with 39 | ## `std::pair`, having members `first` and `second`. Note that this 40 | ## is in the `examples` namespace (namespaces are optional but 41 | ## supported). 42 | 43 | ## Suppose we want to generate an interface for this class supporting 44 | ## integers, doubles and strings. We can write yaml: 45 | ##+ echo=FALSE, results="asis" 46 | yaml <- readLines(file.path(path, "inst/RcppR6_classes.yml")) 47 | i_pair2 <- grep("pair2:", yaml) 48 | yaml1 <- yaml[1:(i_pair2 - 2)] 49 | yaml2 <- yaml[i_pair2:length(yaml)] 50 | i_templates <- grep("\\s+templates:", yaml1)[[1]] 51 | i_constructor <- grep("\\s+constructor:", yaml1)[[1]] 52 | i_active <- grep("\\s+active:", yaml1)[[1]] 53 | yaml_output(yaml1) 54 | 55 | ## There's a new section here compared with the previous classes: 56 | ## `templates:`. The presence of this element means that RcppR6 will 57 | ## generate templated classes. 58 | ##+ echo=FALSE, results="asis" 59 | yaml_output(yaml1[i_templates:(i_constructor - 1)]) 60 | 61 | ## The `parameters:` field indicates which bits of the full name 62 | ## `name_cpp:`, here `examples::pair1`, are types. 63 | ## 64 | ## This is paired with a field `concrete` which contains a list of 65 | ## substitutions. So this will create interfaces for 66 | ## `examples::pair1`, `examples::pair1` and 67 | ## `examples::pair1`. The `std::string` type contains an 68 | ## *alias* here to `string`; this is the name that will be used on the 69 | ## R side (see below). 70 | 71 | ## After that is `constructor:` and `active:` fields the same as 72 | ## before. However, types with a `T` (or whatever was declared in the 73 | ## `parameters:` field) can be used and they will be mapped onto a 74 | ## concrete type in the generated object. So `first:` will return an 75 | ## `int` from a `examples::pair1` for example. 76 | RcppR6::install(path) 77 | 78 | ## Run `devtools::document` to create the `NAMESPACE` file 79 | devtools::document(path) 80 | ## and load the generated code: 81 | devtools::load_all(path) 82 | 83 | ## RcppR6 has generated a `pair` function that takes an argument `T`; 84 | ## this is the *name* of the type. (In theory, S3 dispatch could be 85 | ## better here, with the the generator as a generic function, but that 86 | ## would require that the templated type was always first) 87 | args(pair1) 88 | 89 | ## Specifying a type here, returns a function that takes the 90 | ## arguments `a` and `b`. 91 | args(pair1("int")) 92 | 93 | ## which we could use like: 94 | p <- pair1("int")(1L, 2L) 95 | 96 | ## The generated object can be used according to the interface 97 | ## specified above: all it has are read/write fields that type 98 | ## integers: 99 | p$first 100 | p$first <- 10 101 | p$second 102 | p$second <- 20 103 | 104 | ## and these fields are restricted to being integers: 105 | ##+ error=TRUE 106 | p$second <- "second" 107 | p$second 108 | 109 | ## The object has multiple S3 types: 110 | class(p) 111 | 112 | ## ...so generic functions can be written for `pair1` and they'll 113 | ## dispatch for all `pair` types. If special treatment is required 114 | ## for a single type, then use `pair``. 115 | 116 | ## Similarly, for `pair1`: 117 | p_double <- pair1("double")(exp(1), pi) 118 | p_double$first 119 | p_double$second 120 | class(p_double) 121 | 122 | ## ...and for `pair1`: 123 | p_string <- pair1("string")("first", "second") 124 | p_string$first 125 | p_string$second 126 | class(p_string) 127 | 128 | ## Similarly, template types can be generated for types that have more 129 | ## than one template parameter, such as `std::pair` itself. 130 | ##+ echo=FALSE, results="asis" 131 | yaml_output(yaml2) 132 | 133 | ## This is basically the same as above, except that: 134 | ## 135 | ## * an ordered of type parameters are given for `parameters` 136 | ## * the concrete types are given as yaml lists or ordered maps (to 137 | ## handle renaming). 138 | ## 139 | ## Apart from that, nothing is different. 140 | 141 | ## This is already compiled in from above. `pair` takes two arguments: 142 | args(pair2) 143 | 144 | ## and is initialised in the same way as above: types go in the first 145 | ## call, arguments in the second. This generates a `std::pair`: 147 | p2 <- pair2("int", "double")(1L, pi) 148 | p2$first 149 | p2$second 150 | 151 | ## and this generates a `std::pair` 152 | p2 <- pair2("string", "double")("first", pi) 153 | p2$first 154 | p2$second 155 | 156 | ## The approach RcppR6 takes is very naive and will just go ahead and 157 | ## generate a lot of boilerplate. That could create large binaries 158 | ## (though probably no larger than `boost::variant` or `boost::any`). 159 | 160 | ## # Using templated types in functions 161 | 162 | ## Now we have a problem. With non-templated types we can use Rcpp to 163 | ## easily write functions that use the generated classes. You can 164 | ## still do that for fully-specified types: 165 | 166 | ## ```c++ 167 | ## // [[Rcpp::export]] 168 | ## int first(pair x) { 169 | ## return x.first; 170 | ## } 171 | ## ``` 172 | 173 | ## But how to write a function that would return the first of *any* 174 | ## pair? This *will not work*: 175 | 176 | ## ```c++ 177 | ## // [[Rcpp::export]] 178 | ## template 179 | ## T first(pair x) { 180 | ## return x.first; 181 | ## } 182 | ## ``` 183 | 184 | ## It won't work because Rcpp does not know what combinations of `T` 185 | ## and `U` to generate code for. RcppR6 can help here by doing some 186 | ## code generation for you. 187 | 188 | ## # Contents of generated files: 189 | 190 | ## `inst/include/templates/RcppR6_pre.hpp`: 191 | ##+ echo=FALSE, results="asis" 192 | cpp_output(readLines(file.path(path, "inst/include/templates/RcppR6_pre.hpp"))) 193 | 194 | ## `inst/include/templates/RcppR6_post.hpp`: 195 | ##+ echo=FALSE, results="asis" 196 | cpp_output(readLines(file.path(path, "inst/include/templates/RcppR6_post.hpp"))) 197 | 198 | ## `inst/include/templates/RcppR6_support.hpp`: 199 | ##+ echo=FALSE, results="asis" 200 | cpp_output(readLines(file.path(path, "inst/include/templates/RcppR6_support.hpp"))) 201 | 202 | ## `R/RcppR6.R`: 203 | ##+ echo=FALSE, results="asis" 204 | r_output(readLines(file.path(path, "R/RcppR6.R"))) 205 | 206 | ## `R/RcppR6.R`: 207 | ##+ echo=FALSE, results="asis" 208 | cpp_output(readLines(file.path(path, "src/RcppR6.cpp"))) 209 | -------------------------------------------------------------------------------- /vignettes/templates.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "RcppR6 templates" 3 | author: "Rich FitzJohn" 4 | date: "`r Sys.Date()`" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{RcppR6 templates} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | %\VignetteEncoding{UTF-8} 10 | --- 11 | 12 | One of the reasons for writing RcppR6 is for exporting templated 13 | classes. I think I have the basics working reasonably well here, 14 | but this is definitely an area that might get changed. 15 | 16 | The problem is this: if you have some templated type, say 17 | ```std::pair```, then you need to write wrappers for all the 18 | types `T` and `U` that you need, and arrange for the correct 19 | dispatch on the R side. 20 | 21 | The way that this is done behind the scenes in RcppR6 is not 22 | particularly pretty and might change. 23 | 24 | To see how this works, we'll start wrapping `std::pair`. This is 25 | just a tuple of data of some type. C++ will need to know the 26 | *actual* types. This example is in the `templates` example package. 27 | 28 | First, consider the simple case of a pair of the same type. To do 29 | this, here's a small class definition (in 30 | `inst/include/templates/pair1.hpp`). 31 | ``` {r echo=FALSE, results="asis"} 32 | set.seed(1) 33 | source(system.file("vignette_common.R", package="RcppR6")) 34 | path <- vignette_prepare("templates") 35 | cpp_output(readLines(file.path(path, "inst/include/templates/pair1.hpp"))) 36 | ``` 37 | 38 | There's not much going on here: this is just a class that stores 39 | two things of the same type. It's fairly compatible with 40 | `std::pair`, having members `first` and `second`. Note that this 41 | is in the `examples` namespace (namespaces are optional but 42 | supported). 43 | 44 | Suppose we want to generate an interface for this class supporting 45 | integers, doubles and strings. We can write yaml: 46 | ``` {r echo=FALSE, results="asis"} 47 | yaml <- readLines(file.path(path, "inst/RcppR6_classes.yml")) 48 | i_pair2 <- grep("pair2:", yaml) 49 | yaml1 <- yaml[1:(i_pair2 - 2)] 50 | yaml2 <- yaml[i_pair2:length(yaml)] 51 | i_templates <- grep("\\s+templates:", yaml1)[[1]] 52 | i_constructor <- grep("\\s+constructor:", yaml1)[[1]] 53 | i_active <- grep("\\s+active:", yaml1)[[1]] 54 | yaml_output(yaml1) 55 | ``` 56 | 57 | There's a new section here compared with the previous classes: 58 | `templates:`. The presence of this element means that RcppR6 will 59 | generate templated classes. 60 | ``` {r echo=FALSE, results="asis"} 61 | yaml_output(yaml1[i_templates:(i_constructor - 1)]) 62 | ``` 63 | 64 | The `parameters:` field indicates which bits of the full name 65 | `name_cpp:`, here `examples::pair1`, are types. 66 | 67 | This is paired with a field `concrete` which contains a list of 68 | substitutions. So this will create interfaces for 69 | `examples::pair1`, `examples::pair1` and 70 | `examples::pair1`. The `std::string` type contains an 71 | *alias* here to `string`; this is the name that will be used on the 72 | R side (see below). 73 | 74 | After that is `constructor:` and `active:` fields the same as 75 | before. However, types with a `T` (or whatever was declared in the 76 | `parameters:` field) can be used and they will be mapped onto a 77 | concrete type in the generated object. So `first:` will return an 78 | `int` from a `examples::pair1` for example. 79 | ``` {r } 80 | RcppR6::install(path) 81 | ``` 82 | 83 | Run `devtools::document` to create the `NAMESPACE` file 84 | ``` {r } 85 | devtools::document(path) 86 | ``` 87 | and load the generated code: 88 | ``` {r } 89 | devtools::load_all(path) 90 | ``` 91 | 92 | RcppR6 has generated a `pair` function that takes an argument `T`; 93 | this is the *name* of the type. (In theory, S3 dispatch could be 94 | better here, with the the generator as a generic function, but that 95 | would require that the templated type was always first) 96 | ``` {r } 97 | args(pair1) 98 | ``` 99 | 100 | Specifying a type here, returns a function that takes the 101 | arguments `a` and `b`. 102 | ``` {r } 103 | args(pair1("int")) 104 | ``` 105 | 106 | which we could use like: 107 | ``` {r } 108 | p <- pair1("int")(1L, 2L) 109 | ``` 110 | 111 | The generated object can be used according to the interface 112 | specified above: all it has are read/write fields that type 113 | integers: 114 | ``` {r } 115 | p$first 116 | p$first <- 10 117 | p$second 118 | p$second <- 20 119 | ``` 120 | 121 | and these fields are restricted to being integers: 122 | ``` {r error=TRUE} 123 | p$second <- "second" 124 | p$second 125 | ``` 126 | 127 | The object has multiple S3 types: 128 | ``` {r } 129 | class(p) 130 | ``` 131 | 132 | ...so generic functions can be written for `pair1` and they'll 133 | dispatch for all `pair` types. If special treatment is required 134 | for a single type, then use `pair``. 135 | 136 | Similarly, for `pair1`: 137 | ``` {r } 138 | p_double <- pair1("double")(exp(1), pi) 139 | p_double$first 140 | p_double$second 141 | class(p_double) 142 | ``` 143 | 144 | ...and for `pair1`: 145 | ``` {r } 146 | p_string <- pair1("string")("first", "second") 147 | p_string$first 148 | p_string$second 149 | class(p_string) 150 | ``` 151 | 152 | Similarly, template types can be generated for types that have more 153 | than one template parameter, such as `std::pair` itself. 154 | ``` {r echo=FALSE, results="asis"} 155 | yaml_output(yaml2) 156 | ``` 157 | 158 | This is basically the same as above, except that: 159 | 160 | * an ordered of type parameters are given for `parameters` 161 | * the concrete types are given as yaml lists or ordered maps (to 162 | handle renaming). 163 | 164 | Apart from that, nothing is different. 165 | 166 | This is already compiled in from above. `pair` takes two arguments: 167 | ``` {r } 168 | args(pair2) 169 | ``` 170 | 171 | and is initialised in the same way as above: types go in the first 172 | call, arguments in the second. This generates a `std::pair`: 174 | ``` {r } 175 | p2 <- pair2("int", "double")(1L, pi) 176 | p2$first 177 | p2$second 178 | ``` 179 | 180 | and this generates a `std::pair` 181 | ``` {r } 182 | p2 <- pair2("string", "double")("first", pi) 183 | p2$first 184 | p2$second 185 | ``` 186 | 187 | The approach RcppR6 takes is very naive and will just go ahead and 188 | generate a lot of boilerplate. That could create large binaries 189 | (though probably no larger than `boost::variant` or `boost::any`). 190 | 191 | # Contents of generated files: 192 | 193 | `inst/include/templates/RcppR6_pre.hpp`: 194 | ``` {r echo=FALSE, results="asis"} 195 | cpp_output(readLines(file.path(path, "inst/include/templates/RcppR6_pre.hpp"))) 196 | ``` 197 | 198 | `inst/include/templates/RcppR6_post.hpp`: 199 | ``` {r echo=FALSE, results="asis"} 200 | cpp_output(readLines(file.path(path, "inst/include/templates/RcppR6_post.hpp"))) 201 | ``` 202 | 203 | `inst/include/templates/RcppR6_support.hpp`: 204 | ``` {r echo=FALSE, results="asis"} 205 | cpp_output(readLines(file.path(path, "inst/include/templates/RcppR6_support.hpp"))) 206 | ``` 207 | 208 | `R/RcppR6.R`: 209 | ``` {r echo=FALSE, results="asis"} 210 | r_output(readLines(file.path(path, "R/RcppR6.R"))) 211 | ``` 212 | 213 | `R/RcppR6.R`: 214 | ``` {r echo=FALSE, results="asis"} 215 | cpp_output(readLines(file.path(path, "src/RcppR6.cpp"))) 216 | ``` 217 | --------------------------------------------------------------------------------