[Rcpp-commits] r2126 - pkg/Rcpp/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Sep 17 10:56:21 CEST 2010
Author: romain
Date: 2010-09-17 10:56:21 +0200 (Fri, 17 Sep 2010)
New Revision: 2126
Added:
pkg/Rcpp/R/01_show.R
pkg/Rcpp/R/02_completion.R
pkg/Rcpp/R/03_prompt.R
Modified:
pkg/Rcpp/R/Module.R
Log:
add comments and move things around so that Module.R is kept to the essentials
Added: pkg/Rcpp/R/01_show.R
===================================================================
--- pkg/Rcpp/R/01_show.R (rev 0)
+++ pkg/Rcpp/R/01_show.R 2010-09-17 08:56:21 UTC (rev 2126)
@@ -0,0 +1,68 @@
+# Copyright (C) 2010 John Chambers, Dirk Eddelbuettel and Romain Francois
+#
+# This file is part of Rcpp.
+#
+# Rcpp is free software: you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 2 of the License, or
+# (at your option) any later version.
+#
+# Rcpp is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
+
+setMethod( "show", "C++Object", function(object){
+ txt <- sprintf( "C++ object <%s> of class '%s' <%s>",
+ externalptr_address(object at pointer),
+ .Call( "Class__name", object at cppclass, PACKAGE = "Rcpp" ),
+ externalptr_address(object at cppclass)
+ )
+ writeLines( txt )
+} )
+
+setMethod( "show", "C++Class", function(object){
+ txt <- sprintf( "C++ class '%s' <%s>",
+ .Call( "Class__name", object at pointer, PACKAGE = "Rcpp" ),
+ externalptr_address(object at pointer) )
+ writeLines( txt )
+
+ met <- .Call( "CppClass__methods", object at pointer, PACKAGE = "Rcpp" )
+ if( length( met ) ){
+ txt <- sprintf( "\n%d methods : \n%s", length(met), paste( sprintf(" %s", met), collapse = "\n") )
+ writeLines( txt )
+ }
+} )
+
+setMethod( "show", "C++Function", function(object){
+ writeLines( sprintf( "internal C++ function <%s>", externalptr_address(object at pointer) ) )
+} )
+
+setMethod( "show", "Module", function( object ){
+ pointer <- .getModulePointer(object, FALSE)
+ if(identical(pointer, .badModulePointer)) {
+ object <- as.environment(object) ## not needed when 2.12.0 arrives
+ txt <- sprintf("Uninitialized module named \"%s\" from package \"%s\"",
+ get("moduleName", envir = object),
+ get("packageName", envir = object))
+ writeLines(txt)
+ }
+ else {
+ info <- .Call( "Module__funtions_arity", pointer, PACKAGE = "Rcpp" )
+ name <- .Call( "Module__name", pointer )
+ txt <- sprintf( "Rcpp module '%s' \n\t%d functions: ", name, length(info) )
+ writeLines( txt )
+ txt <- sprintf( "%15s : %d arguments", names(info), info )
+ writeLines( txt )
+
+ info <- .Call( "Module__classes_info", pointer, PACKAGE = "Rcpp" )
+ txt <- sprintf( "\n\t%d classes : ", length(info) )
+ writeLines( txt )
+ txt <- sprintf( "%15s ", names(info) )
+ writeLines( txt )
+ }
+} )
+
Added: pkg/Rcpp/R/02_completion.R
===================================================================
--- pkg/Rcpp/R/02_completion.R (rev 0)
+++ pkg/Rcpp/R/02_completion.R 2010-09-17 08:56:21 UTC (rev 2126)
@@ -0,0 +1,36 @@
+# Copyright (C) 2010 John Chambers, Dirk Eddelbuettel and Romain Francois
+#
+# This file is part of Rcpp.
+#
+# Rcpp is free software: you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 2 of the License, or
+# (at your option) any later version.
+#
+# Rcpp is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
+
+setGeneric( ".DollarNames" )
+.DollarNames.Module <- function(x, pattern){
+ grep( pattern , .Call( "Module__complete", x at pointer, PACKAGE = "Rcpp"), value = TRUE )
+}
+setMethod( ".DollarNames", "Module", .DollarNames.Module )
+
+# completion for C++ objects
+# do we actually need this or do we get it for free via setRefClass, etc ...
+setGeneric( "complete", function(x) standardGeneric("complete") )
+setMethod( "complete", "C++Object", function(x){
+ xp <- x at cppclass
+ .Call( "CppClass__complete" , xp , PACKAGE = "Rcpp" )
+} )
+
+".DollarNames.C++Object" <- function( x, pattern ){
+ grep( pattern, complete(x), value = TRUE )
+}
+setMethod( ".DollarNames", "C++Object", `.DollarNames.C++Object` )
+
Added: pkg/Rcpp/R/03_prompt.R
===================================================================
--- pkg/Rcpp/R/03_prompt.R (rev 0)
+++ pkg/Rcpp/R/03_prompt.R 2010-09-17 08:56:21 UTC (rev 2126)
@@ -0,0 +1,62 @@
+# Copyright (C) 2010 John Chambers, Dirk Eddelbuettel and Romain Francois
+#
+# This file is part of Rcpp.
+#
+# Rcpp is free software: you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 2 of the License, or
+# (at your option) any later version.
+#
+# Rcpp is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
+
+setGeneric( "functions", function(object, ...) standardGeneric( "functions" ) )
+setMethod( "functions", "Module", function(object, ...){
+ pointer <- .getModulePointer(object)
+ if(identical(pointer, .badModulePointer))
+ stop(gettextf("Module \"%s\" has not been intialized: try Module(object)",
+ get("moduleName", envir = as.environment(object))), domain = NA)
+ else
+ .Call( "Module__funtions_arity", pointer, PACKAGE = "Rcpp" )
+} )
+
+setGeneric( "prompt" )
+setMethod( "prompt", "Module", function(object, filename = NULL, name = NULL, ...){
+ lines <- readLines( system.file( "prompt", "module.Rd", package = "Rcpp" ) )
+ if( is.null(name) ) name <- .Call( "Module__name", object at pointer, PACKAGE = "Rcpp" )
+ if( is.null(filename) ) filename <- sprintf( "%s-module.Rd", name )
+ lines <- gsub( "NAME", name, lines )
+
+ info <- functions( object )
+ f.txt <- if( length( info ) ){
+ sprintf( "functions: \\\\describe{
+%s
+ }", paste( sprintf( " \\\\item{%s}{ ~~ description of function %s ~~ }", names(info), names(info) ), collapse = "\n" ) )
+ } else {
+ ""
+ }
+ lines <- sub( "FUNCTIONS", f.txt, lines )
+
+ ## at this point functions() would have failed if the
+ ## pointer in object was not valid
+ pointer <- .getModulePointer(object)
+
+ classes <- .Call( "Module__classes_info", pointer, PACKAGE = "Rcpp" )
+ c.txt <- if( length( classes ) ){
+ sprintf( "classes: \\\\describe{
+%s
+ }", paste( sprintf( " \\\\item{%s}{ ~~ description of class %s ~~ }", names(classes), names(classes) ), collapse = "\n" ) )
+ } else {
+ ""
+ }
+ lines <- sub( "CLASSES", c.txt, lines )
+
+ writeLines( lines, filename )
+ invisible(NULL)
+} )
+
Modified: pkg/Rcpp/R/Module.R
===================================================================
--- pkg/Rcpp/R/Module.R 2010-09-17 08:34:53 UTC (rev 2125)
+++ pkg/Rcpp/R/Module.R 2010-09-17 08:56:21 UTC (rev 2126)
@@ -28,9 +28,6 @@
o at pointer <- pointer
o
}
-setMethod( "show", "C++Function", function(object){
- writeLines( sprintf( "internal C++ function <%s>", externalptr_address(object at pointer) ) )
-} )
setMethod("$", "C++Class", function(x, name) {
x <- .getCppGenerator(x)
@@ -91,37 +88,6 @@
}
} )
-setMethod( "show", "Module", function( object ){
- pointer <- .getModulePointer(object, FALSE)
- if(identical(pointer, .badModulePointer)) {
- object <- as.environment(object) ## not needed when 2.12.0 arrives
- txt <- sprintf("Uninitialized module named \"%s\" from package \"%s\"",
- get("moduleName", envir = object),
- get("packageName", envir = object))
- writeLines(txt)
- }
- else {
- info <- .Call( "Module__funtions_arity", pointer, PACKAGE = "Rcpp" )
- name <- .Call( "Module__name", pointer )
- txt <- sprintf( "Rcpp module '%s' \n\t%d functions: ", name, length(info) )
- writeLines( txt )
- txt <- sprintf( "%15s : %d arguments", names(info), info )
- writeLines( txt )
-
- info <- .Call( "Module__classes_info", pointer, PACKAGE = "Rcpp" )
- txt <- sprintf( "\n\t%d classes : ", length(info) )
- writeLines( txt )
- txt <- sprintf( "%15s ", names(info) )
- writeLines( txt )
- }
-} )
-
-setGeneric( ".DollarNames" )
-.DollarNames.Module <- function(x, pattern){
- grep( pattern , .Call( "Module__complete", x at pointer, PACKAGE = "Rcpp"), value = TRUE )
-}
-setMethod( ".DollarNames", "Module", .DollarNames.Module )
-
## new_CppObject_temp <- function(Class, ...)
## .new_CppObject_xp(Class at pointer, Class at module, ...)
@@ -279,7 +245,11 @@
fc <- .Call( "CppClass__property_classes", CLASS at pointer, PACKAGE = "Rcpp" )
class_names <- names( fc )
-
+
+ # [romain] perhaps we should have something like "C++Property"
+ # instead of "ANY" with appropriate setAs/setIs methods
+ # or maybe change setRefClass so that it takes a "refFields"
+ # argument instead of the trio fieldClasses, fieldPrototypes, fieldReadOnly
fieldClasses <- rep( list( "ANY" ), length( class_names ) )
names( fieldClasses ) <- class_names
@@ -325,84 +295,6 @@
module
}
-setGeneric( "complete", function(x) standardGeneric("complete") )
-setMethod( "complete", "C++Object", function(x){
- xp <- x at cppclass
- .Call( "CppClass__complete" , xp , PACKAGE = "Rcpp" )
-} )
-
-".DollarNames.C++Object" <- function( x, pattern ){
- grep( pattern, complete(x), value = TRUE )
-}
-setMethod( ".DollarNames", "C++Object", `.DollarNames.C++Object` )
-
-setGeneric( "functions", function(object, ...) standardGeneric( "functions" ) )
-setMethod( "functions", "Module", function(object, ...){
- pointer <- .getModulePointer(object)
- if(identical(pointer, .badModulePointer))
- stop(gettextf("Module \"%s\" has not been intialized: try Module(object)",
- get("moduleName", envir = as.environment(object))), domain = NA)
- else
- .Call( "Module__funtions_arity", pointer, PACKAGE = "Rcpp" )
-} )
-
-setGeneric( "prompt" )
-setMethod( "prompt", "Module", function(object, filename = NULL, name = NULL, ...){
- lines <- readLines( system.file( "prompt", "module.Rd", package = "Rcpp" ) )
- if( is.null(name) ) name <- .Call( "Module__name", object at pointer, PACKAGE = "Rcpp" )
- if( is.null(filename) ) filename <- sprintf( "%s-module.Rd", name )
- lines <- gsub( "NAME", name, lines )
-
- info <- functions( object )
- f.txt <- if( length( info ) ){
- sprintf( "functions: \\\\describe{
-%s
- }", paste( sprintf( " \\\\item{%s}{ ~~ description of function %s ~~ }", names(info), names(info) ), collapse = "\n" ) )
- } else {
- ""
- }
- lines <- sub( "FUNCTIONS", f.txt, lines )
-
- ## at this point functions() would have failed if the
- ## pointer in object was not valid
- pointer <- .getModulePointer(object)
-
- classes <- .Call( "Module__classes_info", pointer, PACKAGE = "Rcpp" )
- c.txt <- if( length( classes ) ){
- sprintf( "classes: \\\\describe{
-%s
- }", paste( sprintf( " \\\\item{%s}{ ~~ description of class %s ~~ }", names(classes), names(classes) ), collapse = "\n" ) )
- } else {
- ""
- }
- lines <- sub( "CLASSES", c.txt, lines )
-
- writeLines( lines, filename )
- invisible(NULL)
-} )
-
-setMethod( "show", "C++Object", function(object){
- txt <- sprintf( "C++ object <%s> of class '%s' <%s>",
- externalptr_address(object at pointer),
- .Call( "Class__name", object at cppclass, PACKAGE = "Rcpp" ),
- externalptr_address(object at cppclass)
- )
- writeLines( txt )
-} )
-
-setMethod( "show", "C++Class", function(object){
- txt <- sprintf( "C++ class '%s' <%s>",
- .Call( "Class__name", object at pointer, PACKAGE = "Rcpp" ),
- externalptr_address(object at pointer) )
- writeLines( txt )
-
- met <- .Call( "CppClass__methods", object at pointer, PACKAGE = "Rcpp" )
- if( length( met ) ){
- txt <- sprintf( "\n%d methods : \n%s", length(met), paste( sprintf(" %s", met), collapse = "\n") )
- writeLines( txt )
- }
-} )
-
.referenceMethods__cppclass <- function( classDef, where ){
xp <- classDef at pointer
More information about the Rcpp-commits
mailing list