Skip to content

Commit e150eba

Browse files
eddelbuetteleddelbuettel
authored
Merge pull request #886 from mlysy/rcpp-exposeClass
bugfixes for Rcpp::exposeClass
2 parents 12f3c03 + 586d4db commit e150eba

File tree

5 files changed

+127
-13
lines changed

5 files changed

+127
-13
lines changed

‎ChangeLog

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,9 @@
1+
2018-07-24 Martin Lysy <[email protected]>
2+
3+
* R/loadRcppClass.R: Search in R module for 'Class' instead of 'CppClass'.
4+
* R/exposeClass.R: Fixed 'rename' argument to work as expected.
5+
* inst/unitTests/runit.exposeClass.R: Added unit tests for the above.
6+
17
2018-07-23 Dirk Eddelbuettel <[email protected]>
28

39
* inst/bib/Rcpp.bib: More updates
@@ -26,6 +32,10 @@
2632
2018-07-19 Jack Wasey <[email protected]>
2733

2834
* inst/include/Rcpp/r_cast.h: Error and abort if debugging for STRSXP
35+
2018-07-24 Martin Lysy <[email protected]>
36+
* R/loadRcppClass.R: Search in R module for 'Class' instead of 'CppClass'.
37+
* R/exposeClass.R: Fixed 'rename' argument to work as expected.
38+
* inst/unitTests/runit.exposeClass.R: Added unit tests for the above.
2939

3040
2018-07-12 Dirk Eddelbuettel <[email protected]>
3141

‎R/RcppClass.R

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -53,13 +53,13 @@ loadRcppClass <- function(Class, CppClass = Class,
5353
}
5454
mod <- loadModule(module, NULL, env = where, loadNow = TRUE)
5555
storage <- get("storage", envir = as.environment(mod))
56-
if(exists(CppClass, envir = storage, inherits = FALSE)) {
57-
cppclassinfo <- get(CppClass, envir = storage)
56+
if(exists(Class, envir = storage, inherits = FALSE)) {
57+
cppclassinfo <- get(Class, envir = storage)
5858
if(!is(cppclassinfo, "C++Class"))
59-
stop(gettextf("Object \"%s\" in module \"%s\" is not a C++ class description", CppClass, module))
59+
stop(gettextf("Object \"%s\" in module \"%s\" is not a C++ class description", Class, module))
6060
}
6161
else
62-
stop(gettextf("No object \"%s\" in module \"%s\"", CppClass, module))
62+
stop(gettextf("No object \"%s\" in module \"%s\"", Class, module))
6363
allmethods <- .makeCppMethods(methods, cppclassinfo, where)
6464
allfields <- .makeCppFields(fields, cppclassinfo, where)
6565
value <- setRefClass(Class, fields = allfields,

‎R/exposeClass.R

Lines changed: 9 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -92,7 +92,7 @@ exposeClass <- function(class, constructors, fields, methods,
9292
}
9393
if(is.character(file)) {
9494
## are we in a package directory? Writable, searchable src subdirectory:
95-
if(file.access("src",3)==0)
95+
if(file.access("src",3)==0 && (basename(file) == file))
9696
cfile <- file.path("src", file)
9797
else
9898
cfile <- file
@@ -107,7 +107,7 @@ exposeClass <- function(class, constructors, fields, methods,
107107
if(identical(Rfile, TRUE))
108108
Rfile <- sprintf("%sClass.R",class)
109109
if(is.character(Rfile)) {
110-
if(file.access("R",3)==0) # in a package directory
110+
if(file.access("R",3)==0 && (basename(file) == file)) # in a package directory
111111
Rfile <- file.path("R", Rfile)
112112
Rcon <- file(Rfile, "w")
113113
msg <- sprintf("Wrote R file \"%s\"",Rfile)
@@ -136,16 +136,17 @@ exposeClass <- function(class, constructors, fields, methods,
136136
}
137137
writeLines("", mcon)
138138
flds <- .specifyItems(fields)
139-
nm <- names(flds)
139+
nm <- fnm <- names(flds)
140140
rdOnly <- nm %in% readOnly
141141
macros <- ifelse(rdOnly, ".field_readonly", ".field")
142142
test <- nm %in% rename
143143
if(any(test))
144-
nm[test] <- newnames[match(nm[test], newnames)]
144+
nm[test] <- newnames[match(nm[test], rename)]
145145
ns <- NULL
146146
for(i in seq_along(nm)) {
147147
typei <- flds[[i]]
148-
nmi <- fldi <- nm[[i]]
148+
fldi <- fnm[i]
149+
nmi <- nm[[i]]
149150
macroi <- macros[[i]]
150151
if(!length(typei) || identical(typei, "")) ## direct field
151152
writeLines(sprintf(" %s(\"%s\", &%s::%s)",
@@ -171,7 +172,7 @@ exposeClass <- function(class, constructors, fields, methods,
171172
nm <- mds <- names(sigs)
172173
test <- nm %in% rename
173174
if(any(test))
174-
nm[test] <- newnames[match(nm[test], newnames)]
175+
nm[test] <- newnames[match(nm[test], rename)]
175176
for(i in seq_along(nm)) {
176177
sigi <- sigs[[i]]
177178
nmi <- nm[[i]]
@@ -200,11 +201,11 @@ exposeClass <- function(class, constructors, fields, methods,
200201
if(missing(CppClass))
201202
CppString <- ""
202203
else
203-
CppString <- paste(",",dQuote(CppClass))
204+
CppString <- paste0(", \"",CppClass, "\"")
204205
if(missing(module))
205206
ModString <- ""
206207
else
207-
ModString <- paste(", module =", dQuote(module))
208+
ModString <- paste0(", module = \"", module, "\"")
208209
writeLines(sprintf("%s <- setRcppClass(\"%s\"%s%s)",
209210
class, class, CppString,ModString), Rcon)
210211
}

‎inst/unitTests/runit.exposeClass.R

Lines changed: 103 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,103 @@
1+
# Copyright (C) 2013 - 2014 Dirk Eddelbuettel and Romain Francois
2+
#
3+
# This file is part of Rcpp.
4+
#
5+
# Rcpp is free software: you can redistribute it and/or modify it
6+
# under the terms of the GNU General Public License as published by
7+
# the Free Software Foundation, either version 2 of the License, or
8+
# (at your option) any later version.
9+
#
10+
# Rcpp is distributed in the hope that it will be useful, but
11+
# WITHOUT ANY WARRANTY; without even the implied warranty of
12+
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13+
# GNU General Public License for more details.
14+
#
15+
# You should have received a copy of the GNU General Public License
16+
# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
17+
18+
.runThisTest <- Sys.getenv("RunAllRcppTests") == "yes"
19+
20+
if (.runThisTest) {
21+
22+
test.exposeClass <- function(){
23+
24+
tempdir <- tempdir()
25+
## foo has already been loaded in test.Rcpp.package.skeleton.R,
26+
## so named differently here to avoid namespace conflicts
27+
pkg_name <- "fooModule"
28+
path <- tempdir
29+
pkg_path <- file.path(path, pkg_name)
30+
R_path <- file.path(pkg_path, "R")
31+
src_path <- file.path(pkg_path, "src")
32+
foo_header <- "
33+
#ifndef foo_h
34+
#define foo_h 1
35+
// class to set/get double
36+
class foo {
37+
public:
38+
double x;
39+
double get_x() {return x;}
40+
void set_x(double _x) {x = _x; return;}
41+
foo(double _x) {set_x(_x);}
42+
};
43+
#endif
44+
"
45+
46+
## create package
47+
Rcpp.package.skeleton(pkg_name, path=path, environment = environment(),
48+
example_code = FALSE, module = TRUE)
49+
on.exit(unlink(pkg_path, recursive=TRUE))
50+
file.remove(list.files(c(src_path, R_path), full.names = TRUE))
51+
cat(foo_header, file = file.path(src_path, "foo.h"))
52+
53+
## check that result of exposeClass compiles and runs properly
54+
exposeClass(class = "fooR",
55+
constructors = list("double"),
56+
fields = "x",
57+
methods = c("get_x", "set_x"),
58+
header = '#include "foo.h"',
59+
CppClass = "foo",
60+
rename = c(y = "x", get_y = "get_x", set_y = "set_x"),
61+
file = file.path(src_path, "fooModule.cpp"),
62+
Rfile = file.path(R_path, "fooClass.R"))
63+
compileAttributes(pkg_path)
64+
invisible(sapply( list.files( file.path(pkg_path, "man"), full.names=TRUE), unlink ))
65+
66+
## check build
67+
owd <- getwd()
68+
setwd(path)
69+
on.exit( setwd(owd), add=TRUE )
70+
R <- shQuote( file.path( R.home( component = "bin" ), "R" ))
71+
system( paste(R, "CMD build", pkg_path) )
72+
gz_name <- paste0(pkg_name, "_1.0.tar.gz")
73+
checkTrue( file.exists(gz_name), "can successfully R CMD build the pkg")
74+
75+
## check install + require
76+
dir.create("templib")
77+
install.packages(gz_name, file.path(path, "templib"), repos=NULL, type="source")
78+
on.exit( unlink( file.path(path, gz_name) ), add=TRUE)
79+
status <- require(pkg_name, file.path(path, "templib"), character.only=TRUE)
80+
on.exit( unlink( file.path(path, "templib"), recursive=TRUE), add=TRUE )
81+
checkTrue(status, "can successfully require the pkg")
82+
83+
## check object creation
84+
bar <- fooR(0)
85+
env <- environment()
86+
checkTrue( exists("bar", envir = env, inherits = FALSE),
87+
"module object successfully instantiated" )
88+
gs <- replicate(n = 10, {
89+
y <- rnorm(1)
90+
bar$set_y(y)
91+
bar$get_y() - y
92+
})
93+
checkTrue( all(gs == 0), "renamed methods function as expected" )
94+
gs <- replicate(n = 10, {
95+
y <- rnorm(1)
96+
bar$set_y(y)
97+
bar$y - y
98+
})
99+
checkTrue( all(gs == 0), "renamed direct field functions as expected" )
100+
101+
}
102+
103+
}

‎inst/unitTests/testRcppClass/src/stdVector.cpp

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -36,7 +36,7 @@ RCPP_MODULE(stdVector){
3636
using namespace Rcpp ;
3737

3838
// we expose the class std::vector<double> as "vec" on the R side
39-
class_<vec>( "vec")
39+
class_<vec>( "stdNumeric")
4040

4141
// exposing the default constructor
4242
.constructor()

0 commit comments

Comments
 (0)