[Rcpp-commits] r2009 - pkg/Rcpp/inst/include/Rcpp/stats
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Aug 15 12:19:13 CEST 2010
Author: romain
Date: 2010-08-15 12:19:13 +0200 (Sun, 15 Aug 2010)
New Revision: 2009
Modified:
pkg/Rcpp/inst/include/Rcpp/stats/logis.h
pkg/Rcpp/inst/include/Rcpp/stats/nbinom_mu.h
Log:
converting logis and nbinom_mu to RCPP_DPQ
Modified: pkg/Rcpp/inst/include/Rcpp/stats/logis.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/stats/logis.h 2010-08-15 09:47:25 UTC (rev 2008)
+++ pkg/Rcpp/inst/include/Rcpp/stats/logis.h 2010-08-15 10:19:13 UTC (rev 2009)
@@ -1,8 +1,5 @@
-
// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 4 -*-
//
-// auto generated file (from script/stats.R)
-//
// logis.h: Rcpp R/C++ interface class library --
//
// Copyright (C) 2010 Douglas Bates, Dirk Eddelbuettel and Romain Francois
@@ -25,93 +22,115 @@
#ifndef Rcpp__stats__logis_h
#define Rcpp__stats__logis_h
-namespace Rcpp {
-namespace stats {
+namespace Rcpp{
+namespace stats{
+inline double dlogis_0(double x /*, double location [=0.0], double scale [=1.0] */, int give_log){
+ double e, f;
+#ifdef IEEE_754
+ if (ISNAN(x))
+ return x + 1.0 ;
+#endif
+
+ e = ::exp(-::fabs(x));
+ f = 1.0 + e ;
+ return give_log ? -(x + ::log(f * f)) : e / (f * f);
+}
- template <bool NA, typename T>
- class DLogis : public Rcpp::VectorBase< REALSXP, NA, DLogis<NA,T> >{
- public:
- typedef typename Rcpp::VectorBase<REALSXP,NA,T> VEC_TYPE;
+inline double dlogis_1(double x, double location /*, double scale [=1.0] */, int give_log){
+ double e, f;
+#ifdef IEEE_754
+ if (ISNAN(x) || ISNAN(location))
+ return x + location + 1.0;
+#endif
+
+ x = ::fabs((x - location) );
+ e = ::exp(-x);
+ f = 1.0 + e;
+ return give_log ? -(x + ::log(f * f)) : e / (f * f);
+}
- DLogis( const VEC_TYPE& vec_, double location_ = 0.0, double scale_ = 1.0 , bool log_ = false ) :
- vec(vec_), location(location_), scale(scale_) , log(log_) {}
-
- inline double operator[]( int i) const {
- return ::Rf_dlogis( vec[i], location, scale , log );
- }
-
- inline int size() const { return vec.size(); }
-
- private:
- const VEC_TYPE& vec;
- double location; double scale;
- int log;
-
- };
- template <bool NA, typename T>
- class PLogis : public Rcpp::VectorBase< REALSXP, NA, PLogis<NA,T> >{
- public:
- typedef typename Rcpp::VectorBase<REALSXP,NA,T> VEC_TYPE;
-
- PLogis( const VEC_TYPE& vec_, double location_ = 0.0, double scale_ = 1.0 ,
- bool lower_tail = true, bool log_ = false ) :
- vec(vec_), location(location_), scale(scale_) , lower(lower_tail), log(log_) {}
-
- inline double operator[]( int i) const {
- return ::Rf_plogis( vec[i], location, scale, lower, log );
- }
-
- inline int size() const { return vec.size(); }
-
- private:
- const VEC_TYPE& vec;
- double location; double scale;
- int lower, log;
-
- };
+inline double plogis_0(double x /*, double location [=0.0] , double scale [=1.0] */,
+ int lower_tail, int log_p) {
+#ifdef IEEE_754
+ if (ISNAN(x) )
+ return x + 1.0 ;
+#endif
+
+ if (ISNAN(x)) return R_NaN ;
+ R_P_bounds_Inf_01(x);
- template <bool NA, typename T>
- class QLogis : public Rcpp::VectorBase< REALSXP, NA, QLogis<NA,T> >{
- public:
- typedef typename Rcpp::VectorBase<REALSXP,NA,T> VEC_TYPE;
-
- QLogis( const VEC_TYPE& vec_, double location_ = 0.0, double scale_ = 1.0 ,
- bool lower_tail = true, bool log_ = false ) :
- vec(vec_), location(location_), scale(scale_), lower(lower_tail), log(log_) {}
-
- inline double operator[]( int i) const {
- return ::Rf_qlogis( vec[i], location, scale, lower, log );
- }
-
- inline int size() const { return vec.size(); }
-
- private:
- const VEC_TYPE& vec;
- double location; double scale;
- int lower, log;
-
- };
-
-} // stats
+ x = ::exp(lower_tail ? -x : x);
+ return (log_p ? -::log1p(x) : 1 / (1 + x));
+}
-template <bool NA, typename T>
-inline stats::DLogis<NA,T> dlogis( const Rcpp::VectorBase<REALSXP,NA,T>& x, double location_ = 0.0, double scale_ = 1.0, bool log = false ) {
- return stats::DLogis<NA,T>( x, location_, scale_, log );
+
+inline double plogis_1(double x, double location /*, double scale [=1.0] */,
+ int lower_tail, int log_p) {
+#ifdef IEEE_754
+ if (ISNAN(x) || ISNAN(location) )
+ return x + location + 1.0 ;
+#endif
+
+ x = (x - location) ;
+ if (ISNAN(x)) return R_NaN ;
+ R_P_bounds_Inf_01(x);
+
+ x = ::exp(lower_tail ? -x : x);
+ return (log_p ? -::log1p(x) : 1 / (1 + x));
}
-template <bool NA, typename T>
-inline stats::PLogis<NA,T> plogis( const Rcpp::VectorBase<REALSXP,NA,T>& x, double location_ = 0.0, double scale_ = 1.0, bool lower = true, bool log = false ) {
- return stats::PLogis<NA,T>( x, location_, scale_, lower, log );
+
+inline double qlogis_0(double p /*, double location [=0.0], double scale [=1.0] */, int lower_tail, int log_p)
+{
+#ifdef IEEE_754
+ if (ISNAN(p))
+ return p + 1.0 ;
+#endif
+ R_Q_P01_boundaries(p, ML_NEGINF, ML_POSINF);
+
+ /* p := logit(p) = log( p / (1-p) ) : */
+ if(log_p) {
+ if(lower_tail)
+ p = p - ::log1p(- ::exp(p));
+ else
+ p = ::log1p(- ::exp(p)) - p;
+ }
+ else
+ p = ::log(lower_tail ? (p / (1. - p)) : ((1. - p) / p));
+
+ return p;
}
-template <bool NA, typename T>
-inline stats::QLogis<NA,T> qlogis( const Rcpp::VectorBase<REALSXP,NA,T>& x, double location_ = 0.0, double scale_ = 1.0, bool lower = true, bool log = false ) {
- return stats::QLogis<NA,T>( x, location_, scale_, lower, log );
+
+inline double qlogis_1(double p, double location /*, double scale [=1.0] */, int lower_tail, int log_p)
+{
+#ifdef IEEE_754
+ if (ISNAN(p) || ISNAN(location))
+ return p + location + 1.0 ;
+#endif
+ R_Q_P01_boundaries(p, ML_NEGINF, ML_POSINF);
+
+ /* p := logit(p) = log( p / (1-p) ) : */
+ if(log_p) {
+ if(lower_tail)
+ p = p - ::log1p(- ::exp(p));
+ else
+ p = ::log1p(- ::exp(p)) - p;
+ }
+ else
+ p = ::log(lower_tail ? (p / (1. - p)) : ((1. - p) / p));
+
+ return location + p;
}
-
+
}
+}
+RCPP_DPQ_0(logis,Rcpp::stats::dlogis_0,Rcpp::stats::plogis_0,Rcpp::stats::qlogis_0)
+RCPP_DPQ_1(logis,Rcpp::stats::dlogis_1,Rcpp::stats::plogis_1,Rcpp::stats::qlogis_1)
+RCPP_DPQ_2(logis,::Rf_dlogis,::Rf_plogis,::Rf_qlogis)
+
#endif
Modified: pkg/Rcpp/inst/include/Rcpp/stats/nbinom_mu.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/stats/nbinom_mu.h 2010-08-15 09:47:25 UTC (rev 2008)
+++ pkg/Rcpp/inst/include/Rcpp/stats/nbinom_mu.h 2010-08-15 10:19:13 UTC (rev 2009)
@@ -1,8 +1,5 @@
-
// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 4 -*-
//
-// auto generated file (from script/stats.R)
-//
// nbinom_mu.h: Rcpp R/C++ interface class library --
//
// Copyright (C) 2010 Douglas Bates, Dirk Eddelbuettel and Romain Francois
@@ -25,93 +22,7 @@
#ifndef Rcpp__stats__nbinom_mu_h
#define Rcpp__stats__nbinom_mu_h
-namespace Rcpp {
-namespace stats {
+RCPP_DPQ_2(nbinom_mu,::Rf_dnbinom_mu, ::Rf_pnbinom_mu, ::Rf_qnbinom_mu )
-
- template <bool NA, typename T>
- class DNbinom_mu : public Rcpp::VectorBase< REALSXP, NA, DNbinom_mu<NA,T> >{
- public:
- typedef typename Rcpp::VectorBase<REALSXP,NA,T> VEC_TYPE;
-
- DNbinom_mu( const VEC_TYPE& vec_, int size_, double mu_ , bool log_ = false ) :
- vec(vec_), siz(size_), mu(mu_) , log(log_) {}
-
- inline double operator[]( int i) const {
- return ::dnbinom_mu( vec[i], siz, mu , log );
- }
-
- inline int size() const { return vec.size(); }
-
- private:
- const VEC_TYPE& vec;
- int siz; double mu;
- int log;
-
- };
-
- template <bool NA, typename T>
- class PNbinom_mu : public Rcpp::VectorBase< REALSXP, NA, PNbinom_mu<NA,T> >{
- public:
- typedef typename Rcpp::VectorBase<REALSXP,NA,T> VEC_TYPE;
-
- PNbinom_mu( const VEC_TYPE& vec_, int size_, double mu_ ,
- bool lower_tail = true, bool log_ = false ) :
- vec(vec_), siz(size_), mu(mu_) , lower(lower_tail), log(log_) {}
-
- inline double operator[]( int i) const {
- return ::pnbinom_mu( vec[i], siz, mu, lower, log );
- }
-
- inline int size() const { return vec.size(); }
-
- private:
- const VEC_TYPE& vec;
- int siz; double mu;
- int lower, log;
-
- };
-
- template <bool NA, typename T>
- class QNbinom_mu : public Rcpp::VectorBase< REALSXP, NA, QNbinom_mu<NA,T> >{
- public:
- typedef typename Rcpp::VectorBase<REALSXP,NA,T> VEC_TYPE;
-
- QNbinom_mu( const VEC_TYPE& vec_, int size_, double mu_ ,
- bool lower_tail = true, bool log_ = false ) :
- vec(vec_), siz(size_), mu(mu_), lower(lower_tail), log(log_) {}
-
- inline double operator[]( int i) const {
- return ::qnbinom_mu( vec[i], siz, mu, lower, log );
- }
-
- inline int size() const { return vec.size(); }
-
- private:
- const VEC_TYPE& vec;
- int siz; double mu;
- int lower, log;
-
- };
-
-} // stats
-
-template <bool NA, typename T>
-inline stats::DNbinom_mu<NA,T> dnbinom_mu( const Rcpp::VectorBase<REALSXP,NA,T>& x, int size_, double mu_, bool log = false ) {
- return stats::DNbinom_mu<NA,T>( x, size_, mu_, log );
-}
-
-template <bool NA, typename T>
-inline stats::PNbinom_mu<NA,T> pnbinom_mu( const Rcpp::VectorBase<REALSXP,NA,T>& x, int size_, double mu_, bool lower = true, bool log = false ) {
- return stats::PNbinom_mu<NA,T>( x, size_, mu_, lower, log );
-}
-
-template <bool NA, typename T>
-inline stats::QNbinom_mu<NA,T> qnbinom_mu( const Rcpp::VectorBase<REALSXP,NA,T>& x, int size_, double mu_, bool lower = true, bool log = false ) {
- return stats::QNbinom_mu<NA,T>( x, size_, mu_, lower, log );
-}
-
-}
-
#endif
More information about the Rcpp-commits
mailing list