[Rcpp-commits] r1940 - scripts

[noreply at r-forge.r-project.org]

Author: romain
Date: 2010-08-06 09:13:51 +0200 (Fri, 06 Aug 2010)
New Revision: 1940

Added:
   scripts/stats.R
Log:
potential generator script (not finished, not used yet)

Added: scripts/stats.R
===================================================================
--- scripts/stats.R	                        (rev 0)
+++ scripts/stats.R	2010-08-06 07:13:51 UTC (rev 1940)
@@ -0,0 +1,162 @@
+
+
+cook <- function( 
+	dist = "norm", 
+	params = list( 
+		mu = list( type = "double", default = "0.0" ),
+		sigma = list( type = "double", default = "1.0" ) 
+	), 
+	input = c("double", "integer"), 
+	# output = sprintf("Rcpp/inst/include/Rcpp/stats/%s.h", dist)
+	output = sprintf( "/tmp/%s.h", dist )
+	){
+
+	input <- match.arg( input )	
+	
+	udist <- dist
+	substring( udist, 1, 1 ) <- toupper( substring( udist, 1, 1 ) )
+	
+	param_def  <- paste( sapply(params, "[[", "type"), " ", names(params), "; ", sep = "" )
+	param_def  <- paste( param_def, collapse = "" )
+
+	param_decl <- paste( sapply(params, "[[", "type"), " ", names(params), "_" , sep = "" )
+	for( i in seq_along(params) ){
+		if( "default" %in% names(params[[i]]) ){
+			param_decl[i] <- paste( param_decl[i], " = ", params[[i]][["default"]], sep = "" )
+		}
+	}
+	param_decl <- paste( param_decl, collapse = ", " )
+	
+	param_init <- paste( names(params), "(", names(params), "_)", sep = "" )
+	param_init <- paste( param_init, collapse = ", ")
+	
+	param_list <- paste( names(params), collapse = ", " )
+		
+code <- '
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 4 -*-
+//
+// auto generated file (from script/stats.R) 
+//
+// __DIST__.h: Rcpp R/C++ interface class library -- 
+//
+// Copyright (C) 2010 Douglas Bates, 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/>.
+
+#ifndef Rcpp__stats____DIST___h
+#define Rcpp__stats____DIST___h
+
+namespace Rcpp {
+namespace stats {
+namespace impl {
+
+	template <bool NA, typename T>
+	class D__UDIST__ : public Rcpp::VectorBase< REALSXP, NA, D__UDIST__<NA,T> >{
+	public:
+		typedef typename Rcpp::VectorBase<REALSXP,NA,T> VEC_TYPE;
+	
+		DNorm( const VEC_TYPE& vec_, __PARAM_DECL__ , bool log_ = false ) : 
+			vec(vec_), __PARAM_INIT__ , log(log_) {}
+		
+		inline double operator[]( int i) const {
+			return ::d__DIST__( vec[i], __PARAM_LIST__ , log );
+		}
+		
+		inline int size() const { return vec.size(); }
+		
+	private:
+		const VEC_TYPE& vec;
+		__PARAM_DEF__
+		int log;
+	
+	};
+
+	template <bool NA, typename T>
+	class P__UDIST__ : public Rcpp::VectorBase< REALSXP, NA, P__UDIST__<NA,T> >{
+	public:
+		typedef typename Rcpp::VectorBase<REALSXP,NA,T> VEC_TYPE;
+	
+		P__UDIST__( const VEC_TYPE& vec_, __PARAM_DECL__ ,
+			   bool lower_tail = true, bool log_ = false ) : 
+			vec(vec_), __PARAM_INIT__ , lower(lower_tail), log(log_) {}
+		
+		inline double operator[]( int i) const {
+			return ::p__DIST__( vec[i], __PARAM_LIST__, lower, log );
+		}
+		
+		inline int size() const { return vec.size(); }
+		
+	private:
+		const VEC_TYPE& vec;
+		__PARAM_DEF__
+		int lower, log;
+	
+	};
+
+	template <bool NA, typename T>
+	class Q__UDIST__ : public Rcpp::VectorBase< REALSXP, NA, Q__UDIST__<NA,T> >{
+	public:
+		typedef typename Rcpp::VectorBase<REALSXP,NA,T> VEC_TYPE;
+	
+		Q__UDIST__( const VEC_TYPE& vec_, __PARAM_DECL__ ,
+			   bool lower_tail = true, bool log_ = false ) : 
+			vec(vec_), __PARAM_INIT__, lower(lower_tail), log(log_) {}
+		
+		inline double operator[]( int i) const {
+			return ::q__DIST__( vec[i], __PARAM_LIST__, lower, log );
+		}
+		
+		inline int size() const { return vec.size(); }
+		
+	private:
+		const VEC_TYPE& vec;
+		__PARAM_DEF__
+		int lower, log;
+	
+	};
+	
+} // impl
+
+template <bool NA, typename T>
+inline impl::D__UDIST__<NA,T> d__DIST__( const Rcpp::VectorBase<REALSXP,NA,T>& x, __PARAM_DECL__, bool log = false ) {
+	return impl::D__UDIST__<NA,T>( x, __PARAM_LIST__, log ); 
+}
+
+template <bool NA, typename T>
+inline impl::P__UDIST__<NA,T> p__DIST__( const Rcpp::VectorBase<REALSXP,NA,T>& x, __PARAM_DECL__, bool lower = true, bool log = false ) {
+	return impl::P__UDIST__<NA,T>( x, __PARAM_LIST__, lower, log ); 
+}
+
+template <bool NA, typename T>
+inline impl::Q__UDIST__<NA,T> q__DIST__( const Rcpp::VectorBase<REALSXP,NA,T>& x, __PARAM_DECL__, bool lower = true, bool log = false ) {
+	return impl::Q__UDIST__<NA,T>( x, __PARAM_LIST__, lower, log ); 
+}
+	
+}
+}
+
+#endif
+'
+code <- gsub( "__DIST__" , dist, code, fixed = TRUE )
+code <- gsub( "__UDIST__", udist, code, fixed = TRUE )
+code <- gsub( "__PARAM_INIT__", param_init, code, fixed = TRUE )
+code <- gsub( "__PARAM_LIST__", param_list, code, fixed = TRUE )
+code <- gsub( "__PARAM_DECL__", param_decl, code, fixed = TRUE )
+
+writeLines( code, output )
+
+}
+