[Rcpp-commits] r2852 - in pkg/RcppBDT: . R demo src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Jan 8 19:08:07 CET 2011
Author: edd
Date: 2011-01-08 19:08:07 +0100 (Sat, 08 Jan 2011)
New Revision: 2852
Modified:
pkg/RcppBDT/ChangeLog
pkg/RcppBDT/NAMESPACE
pkg/RcppBDT/R/bdt.R
pkg/RcppBDT/R/zzz.R
pkg/RcppBDT/demo/RcppBDT.R
pkg/RcppBDT/src/RcppBDT.cpp
Log:
added two new functions for date of first and last weekday in a given month and year (eg first Friday in Jan 2011)
changed to per-package environment for module class and object, updated R code and demo accordingly
Modified: pkg/RcppBDT/ChangeLog
===================================================================
--- pkg/RcppBDT/ChangeLog 2011-01-08 15:08:32 UTC (rev 2851)
+++ pkg/RcppBDT/ChangeLog 2011-01-08 18:08:07 UTC (rev 2852)
@@ -1,3 +1,15 @@
+2011-01-08 Dirk Eddelbuettel <edd at debian.org>
+
+ * src/RcppBDT.cpp: Added two new functions for date of first and last
+ weekday in a given month and year (eg first Friday in Jan 2011)
+
+ * R/bdt.R:
+ - added function to export core object for access
+ - changed functions to access core object via per-pack. environment
+ - added functions for first/last day-of-week in month/year
+
+ * demo/RcppBDT.R: updated to keep in sync with other changes
+
2011-01-06 Dirk Eddelbuettel <edd at dexter>
* inst/include/RcppBDT.h: Added paragraph about the UseWithString
Modified: pkg/RcppBDT/NAMESPACE
===================================================================
--- pkg/RcppBDT/NAMESPACE 2011-01-08 15:08:32 UTC (rev 2851)
+++ pkg/RcppBDT/NAMESPACE 2011-01-08 18:08:07 UTC (rev 2852)
@@ -1,4 +1,3 @@
import(Rcpp)
useDynLib(RcppBDT)
exportPattern("^[[:alpha:]]+")
-
Modified: pkg/RcppBDT/R/bdt.R
===================================================================
--- pkg/RcppBDT/R/bdt.R 2011-01-08 15:08:32 UTC (rev 2851)
+++ pkg/RcppBDT/R/bdt.R 2011-01-08 18:08:07 UTC (rev 2852)
@@ -18,50 +18,62 @@
## You should have received a copy of the GNU General Public License
## along with RcppBDT. If not, see <http://www.gnu.org/licenses/>.
+getBDT <- function() {
+ bdtEnv$bdt
+}
+
getEndOfBizWeek <- function(d = Sys.Date()) {
stopifnot(inherits(d, "Date"))
- .bdt$getEndOfBizWeek(d)
+ bdtEnv$bdt$getEndOfBizWeek(d)
}
getEndOfMonth <- function(d = Sys.Date()) {
stopifnot(inherits(d, "Date"))
- .bdt$getEndOfMonth(d)
+ bdtEnv$bdt$getEndOfMonth(d)
}
getYear <- function(d = Sys.Date()) {
stopifnot(inherits(d, "Date"))
- .bdt$fromDate(d)
- .bdt$getYear()
+ bdtEnv$bdt$fromDate(d)
+ bdtEnv$bdt$getYear()
}
getMonth <- function(d = Sys.Date()) {
stopifnot(inherits(d, "Date"))
- .bdt$fromDate(d)
- .bdt$getMonth()
+ bdtEnv$bdt$fromDate(d)
+ bdtEnv$bdt$getMonth()
}
getDay <- function(d = Sys.Date()) {
stopifnot(inherits(d, "Date"))
- .bdt$fromDate(d)
- .bdt$getDay()
+ bdtEnv$bdt$fromDate(d)
+ bdtEnv$bdt$getDay()
}
getDayOfWeek <- function(d = Sys.Date()) {
stopifnot(inherits(d, "Date"))
- .bdt$fromDate(d)
- .bdt$getDayOfWeek()
+ bdtEnv$bdt$fromDate(d)
+ bdtEnv$bdt$getDayOfWeek()
}
getDayOfYear <- function(d = Sys.Date()) {
stopifnot(inherits(d, "Date"))
- .bdt$fromDate(d)
- .bdt$getDayOfYear()
+ bdtEnv$bdt$fromDate(d)
+ bdtEnv$bdt$getDayOfYear()
}
getIMMDate <- function(mon, year) { # defined as third Wednesday
- .bdt$getIMMDate(mon, year)
+ bdtEnv$bdt$getIMMDate(mon, year)
}
getNthDayOfMthWeek <- function(nthday, mthweek, mon, year) {
- .bdt$getNthDayMthWeek(nthday, mthweek, mon, year)
+ bdtEnv$bdt$getNthDayMthWeek(nthday, mthweek, mon, year)
}
+
+getLastDayOfWeekInMonth <- function(nthday, mon, year) {
+ bdtEnv$bdt$getLastDayOfWeekInMonth(nthday, mon, year)
+}
+
+getFirstDayOfWeekInMonth <- function(nthday, mon, year) {
+ bdtEnv$bdt$getFirstDayOfWeekInMonth(nthday, mon, year)
+}
Modified: pkg/RcppBDT/R/zzz.R
===================================================================
--- pkg/RcppBDT/R/zzz.R 2011-01-08 15:08:32 UTC (rev 2851)
+++ pkg/RcppBDT/R/zzz.R 2011-01-08 18:08:07 UTC (rev 2852)
@@ -18,9 +18,25 @@
## You should have received a copy of the GNU General Public License
## along with RcppBDT. If not, see <http://www.gnu.org/licenses/>.
+
+## new environment for our package, local to the package
+bdtEnv <- new.env(parent=emptyenv())
+
.onLoad <- function (lib, pack) {
+
+ ## we need the methods package
require(methods, quiet=TRUE, warn=FALSE)
- .BDTDate <<- Module("bdt")$date
- .bdt <<- new(.BDTDate)
- .bdt$setFromUTC()
+
+ ## new environment for our package, stored in global env
+ #.RcppBDTenv <<- new.env(parent=emptyenv())
+
+ ## Create internal variables
+ #.RcppBDTenv$BDTDate <- Module("bdt")$date
+ #.RcppBDTenv$bdt <- new(.RcppBDTenv$BDTDate)
+ #.RcppBDTenv$bdt$setFromUTC()
+
+ bdtEnv$BDTDate <- Module("bdt")$date
+ bdtEnv$bdt <- new(bdtEnv$BDTDate)
+ bdtEnv$bdt$setFromUTC()
+
}
Modified: pkg/RcppBDT/demo/RcppBDT.R
===================================================================
--- pkg/RcppBDT/demo/RcppBDT.R 2011-01-08 15:08:32 UTC (rev 2851)
+++ pkg/RcppBDT/demo/RcppBDT.R 2011-01-08 18:08:07 UTC (rev 2852)
@@ -3,36 +3,43 @@
require(RcppBDT, quiet=TRUE, warn=FALSE)
- ## this uses the pretty-printing the Rcpp module logic to show
- ## all available functions and their docstring
+ ## this uses the pretty-printing the Rcpp module logic to show all
+ ## available functions and their docstring (symbol now in per-package env)
#print(BDTDate)
- cat("Demo of setters\n");
## first init a base objects for uses for the functions below
- bd <- new(.BDTDate);
- ## alternative constructor: new(.BDTDate, 2010, 01, 02)
- ## then assign new values to the base object -- strings are currently disabled
- #bd$fromString("2010-10-02"); cat("From 2010-10-02 : ", format(bd$getDate()), "\n")
- #bd$fromUndelString("20101003"); cat("From 20101003 : ", format(bd$getDate()), "\n")
- bd$setFromUTC(); cat("From curr. UTC : ", format(bd$getDate()), "\n")
- bd$setFromLocalClock(); cat("From curr. local : ", format(bd$getDate()), "\n")
- bd$setEndOfMonth(); cat("end of month : ", format(bd$getDate()), "\n")
- bd$setFirstOfNextMonth(); cat("1st of next Month: ", format(bd$getDate()), "\n")
- bd$addDays(4); cat("plus four days : ", format(bd$getDate()), "\n")
- bd$subtractDays(3); cat("minus three s : ", format(bd$getDate()), "\n")
+ ## using the instance stored in an internal environment
+ bd <- getBDT()
- bd$setIMMDate(12, 2010); cat("IMM Date Dec 2010: ", format(bd$getDate()), "\n")
- bd$setEndOfBizWeek(); cat("end of biz week : ", format(bd$getDate()), "\n")
+ ## alternative constructors: see R/zzz.R
+ cat("Demo of setters\n");
+ ## conversions from string commented out, see inst/include/RcppBDT.h for details
+ ##bd$fromString("2010-10-02"); cat("From 2010-10-02 : ", format(bd$getDate()), "\n")
+ ##bd$fromUndelString("20101003"); cat("From 20101003 : ", format(bd$getDate()), "\n")
+ bd$setFromUTC(); cat("From curr. UTC : ", format(bd$getDate()), "\n")
+ bd$setFromLocalClock(); cat("From curr. local : ", format(bd$getDate()), "\n")
+ bd$setEndOfMonth(); cat("end of month : ", format(bd$getDate()), "\n")
+ bd$setFirstOfNextMonth(); cat("1st of next Month : ", format(bd$getDate()), "\n")
+ bd$addDays(4); cat("plus four days : ", format(bd$getDate()), "\n")
+ bd$subtractDays(3); cat("minus three days : ", format(bd$getDate()), "\n")
+
+ bd$setIMMDate(12, 2010); cat("IMM Date Dec 2010 : ", format(bd$getDate()), "\n")
+ bd$setEndOfBizWeek(); cat("end of biz week : ", format(bd$getDate()), "\n")
+
cat("\nDemo of getters\n")
## now just functions that return values to R
- cat("From curr. local : ", format(bd$getLocalClock()), "\n")
+ cat("From curr. local : ", format(bd$getLocalClock()), "\n")
bd$setFromLocalClock();
- cat("end of biz week : ", format(bd$getEndOfBizWeek()), "\n")
- cat("end of of month : ", format(bd$getEndOfMonth()), "\n")
- cat("1st of next month: ", format(bd$getFirstOfNextMonth()), "\n")
- cat("IMM Date Dec 2010: ", format(bd$getIMMDate(12, 2010)), "\n")
- cat("3rd Wed Dec 2010 : ", format(bd$getNthDayMthWeek(3, 3, 12, 2010)), "\n")
+ cat("end of biz week : ", format(bd$getEndOfBizWeek()), "\n")
+ cat("end of of month : ", format(bd$getEndOfMonth()), "\n")
+ cat("1st of next month : ", format(bd$getFirstOfNextMonth()), "\n")
+
+ cat("\nDemo of functions\n")
+ cat("IMM Date Dec 2010 : ", format(getIMMDate(12, 2010)), "\n")
+ cat("3rd Wed Dec 2010 : ", format(getNthDayOfMthWeek(3, 3, 12, 2010)), "\n")
+ cat("Last Sat Dec 2010 : ", format(getLastDayOfWeekInMonth(6, 12, 2010)), "\n")
+ cat("First Sat Dec 2010: ", format(getFirstDayOfWeekInMonth(6, 12, 2010)), "\n")
}
demo.RcppBDT()
Modified: pkg/RcppBDT/src/RcppBDT.cpp
===================================================================
--- pkg/RcppBDT/src/RcppBDT.cpp 2011-01-08 15:08:32 UTC (rev 2851)
+++ pkg/RcppBDT/src/RcppBDT.cpp 2011-01-08 18:08:07 UTC (rev 2852)
@@ -115,13 +115,20 @@
}
Rcpp::Date Date_nthDayOfMthWeek(boost::gregorian::date *d, int nthday, int mthweek, int mon, int year) {
- //boost::date_time::nth_kday_of_month<boost::gregorian::date>::week_num
- //nth_dow ans_generator(mthweek,
- nth_dow ans_generator(static_cast<boost::date_time::nth_kday_of_month<boost::gregorian::date>::week_num>(mthweek),
- nthday, mon);
+ nth_dow ans_generator(static_cast<boost::date_time::nth_kday_of_month<boost::gregorian::date>::week_num>(mthweek), nthday, mon);
return Rcpp::wrap(ans_generator.get_date(year));
}
+Rcpp::Date Date_lastDayOfWeekInMonth(boost::gregorian::date *d, int weekday, int mon, int year) {
+ boost::gregorian::last_day_of_the_week_in_month lwdm(weekday, mon);
+ return Rcpp::wrap(lwdm.get_date(year));
+}
+
+Rcpp::Date Date_firstDayOfWeekInMonth(boost::gregorian::date *d, int weekday, int mon, int year) {
+ boost::gregorian::first_day_of_the_week_in_month fwdm(weekday, mon);
+ return Rcpp::wrap(fwdm.get_date(year));
+}
+
RCPP_MODULE(bdt) {
using namespace boost::gregorian;
@@ -187,6 +194,9 @@
.method("getNthDayMthWeek", &Date_nthDayOfMthWeek, "return nth week's given day-of-week in given month and year")
+ .method("getLastDayOfWeekInMonth", &Date_lastDayOfWeekInMonth, "return date of last day-of-week in given month and year")
+ .method("getFirstDayOfWeekInMonth", &Date_firstDayOfWeekInMonth, "return date of last day-of-week in given month and year")
+
;
}
More information about the Rcpp-commits
mailing list