Skip to content

Commit d3800c2

Browse files
eddelbuetteleddelbuettel
committed
tinytest step four: convert dataframe and date tests
skipping both for now for side effects, and binary package input is stale
1 parent 2e18a7f commit d3800c2

File tree

7 files changed

+327
-369
lines changed

7 files changed

+327
-369
lines changed

‎ChangeLog‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,8 @@
55
* inst/tinytest/test_as.R: Idem
66
* inst/tinytest/test_binary_package.R: Idem (but inactive for now)
77
* inst/tinytest/test_client_package.R: Idem (but inactive for now)
8+
* inst/tinytest/test_dataframe.R: Idem
9+
* inst/tinytest/test_date.R: Idem (but condition two test sets on TZ)
810

911
2019-11-23 Dirk Eddelbuettel <edd@debian.org>
1012

inst/unitTests/cpp/DataFrame.cpp renamed to inst/tinytest/cpp/DataFrame.cpp

File renamed without changes.

inst/unitTests/cpp/dates.cpp renamed to inst/tinytest/cpp/dates.cpp

File renamed without changes.

‎inst/tinytest/test_dataframe.R‎

Lines changed: 77 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,77 @@
1+
#!/usr/bin/env r
2+
# -*- mode: R; tab-width: 4; -*-
3+
#
4+
# Copyright (C) 2010 - 2019 Dirk Eddelbuettel and Romain Francois
5+
#
6+
# This file is part of Rcpp.
7+
#
8+
# Rcpp is free software: you can redistribute it and/or modify it
9+
# under the terms of the GNU General Public License as published by
10+
# the Free Software Foundation, either version 2 of the License, or
11+
# (at your option) any later version.
12+
#
13+
# Rcpp is distributed in the hope that it will be useful, but
14+
# WITHOUT ANY WARRANTY; without even the implied warranty of
15+
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16+
# GNU General Public License for more details.
17+
#
18+
# You should have received a copy of the GNU General Public License
19+
# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
20+
21+
.runThisTest <- Sys.getenv("RunAllRcppTests") == "yes"
22+
23+
if (.runThisTest) exit_file("Skipping 'test_dataframe.R'")
24+
25+
library(Rcpp)
26+
sourceCpp("cpp/DataFrame.cpp")
27+
28+
#test.DataFrame.FromSEXP <- function() {
29+
DF <- data.frame(a=1:3, b=c("a","b","c"))
30+
expect_equal( FromSEXP(DF), DF, info = "DataFrame pass-through")
31+
32+
# test.DataFrame.index.byName <- function() {
33+
DF <- data.frame(a=1:3, b=c("a","b","c"))
34+
expect_equal( index_byName(DF, "a"), DF$a, info = "DataFrame column by name 'a'")
35+
expect_equal( index_byName(DF, "b"), DF$b, info = "DataFrame column by name 'b'")
36+
37+
# test.DataFrame.index.byPosition <- function() {
38+
DF <- data.frame(a=1:3, b=c("a","b","c"))
39+
expect_equal( index_byPosition(DF, 0), DF$a, info = "DataFrame column by position 0")
40+
expect_equal( index_byPosition(DF, 1), DF$b, info = "DataFrame column by position 1")
41+
42+
# test.DataFrame.string.element <- function() {
43+
DF <- data.frame(a=1:3, b=c("a","b","c"), stringsAsFactors=FALSE)
44+
expect_equal( string_element(DF), DF[2,"b"], info = "DataFrame string element")
45+
46+
# test.DataFrame.CreateOne <- function() {
47+
DF <- data.frame(a=1:3)
48+
expect_equal( createOne(), DF, info = "DataFrame create1")
49+
50+
# test.DataFrame.CreateTwo <- function() {
51+
DF <- data.frame(a=1:3, b=c("a","b","c"))
52+
expect_equal( createTwo(), DF, info = "DataFrame create2")
53+
54+
# test.DataFrame.SlotProxy <- function(){
55+
setClass("track", representation(x="data.frame", y = "function"))
56+
df <- data.frame( x = 1:10, y = 1:10 )
57+
tr1 <- new( "track", x = df, y = rnorm )
58+
expect_true( identical( SlotProxy(tr1, "x"), df ), info = "DataFrame( SlotProxy )" )
59+
expect_error( SlotProxy(tr1, "y"), info = "DataFrame( SlotProxy ) -> exception" )
60+
61+
# test.DataFrame.AttributeProxy <- function(){
62+
df <- data.frame( x = 1:10, y = 1:10 )
63+
tr1 <- structure( list(), x = df, y = rnorm )
64+
expect_true( identical( AttributeProxy(tr1, "x"), df) , info = "DataFrame( AttributeProxy )" )
65+
expect_error( AttributeProxy(tr1, "y"), info = "DataFrame( AttributeProxy ) -> exception" )
66+
67+
# test.DataFrame.CreateTwo.stringsAsFactors <- function() {
68+
DF <- data.frame(a=1:3, b=c("a","b","c"), stringsAsFactors = FALSE )
69+
expect_equal( createTwoStringsAsFactors(), DF, info = "DataFrame create2 stringsAsFactors = false")
70+
71+
# test.DataFrame.nrow <- function(){
72+
df <- data.frame( x = 1:10, y = 1:10 )
73+
expect_equal( DataFrame_nrow( df ), rep(nrow(df), 2) )
74+
75+
# test.DataFrame.ncol <- function(){
76+
df <- data.frame( x = 1:10, y = 1:10 )
77+
expect_equal( DataFrame_ncol( df ), rep(ncol(df), 2) )

‎inst/tinytest/test_date.R‎

Lines changed: 248 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,248 @@
1+
#!/usr/bin/env r
2+
# -*- mode: R; tab-width: 4; -*-
3+
#
4+
# Copyright (C) 2010 - 2019 Dirk Eddelbuettel and Romain Francois
5+
#
6+
# This file is part of Rcpp.
7+
#
8+
# Rcpp is free software: you can redistribute it and/or modify it
9+
# under the terms of the GNU General Public License as published by
10+
# the Free Software Foundation, either version 2 of the License, or
11+
# (at your option) any later version.
12+
#
13+
# Rcpp is distributed in the hope that it will be useful, but
14+
# WITHOUT ANY WARRANTY; without even the implied warranty of
15+
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16+
# GNU General Public License for more details.
17+
#
18+
# You should have received a copy of the GNU General Public License
19+
# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
20+
21+
.runThisTest <- Sys.getenv("RunAllRcppTests") == "yes"
22+
23+
if (.runThisTest) exit_file("Skipping 'test_date.R'")
24+
25+
library(Rcpp)
26+
sourceCpp("cpp/dates.cpp")
27+
28+
# test.Date.ctor.sexp <- function() {
29+
fun <- ctor_sexp
30+
d <- as.Date("2005-12-31"); expect_equal(fun(d), d, info = "Date.ctor.sexp.1")
31+
d <- as.Date("1970-01-01"); expect_equal(fun(d), d, info = "Date.ctor.sexp.2")
32+
d <- as.Date("1969-12-31"); expect_equal(fun(d), d, info = "Date.ctor.sexp.3")
33+
d <- as.Date("1954-07-04"); expect_equal(fun(d), d, info = "Date.ctor.sexp.4") # cf 'Miracle of Berne' ;-)
34+
d <- as.Date("1789-07-14"); expect_equal(fun(d), d, info = "Date.ctor.sexp.5") # cf 'Quatorze Juillet' ;-)
35+
36+
# test.Date.ctor.notFinite <- function() {
37+
fun <- ctor_sexp
38+
expect_equal(fun(NA), as.Date(NA, origin="1970-01-01"), info = "Date.ctor.na")
39+
expect_equal(fun(NaN), as.Date(NaN, origin="1970-01-01"), info = "Date.ctor.nan")
40+
expect_equal(fun(Inf), as.Date(Inf, origin="1970-01-01"), info = "Date.ctor.inf")
41+
42+
# test.Date.ctor.diffs <- function() {
43+
fun <- ctor_sexp
44+
now <- Sys.Date()
45+
expect_equal(as.numeric(difftime(fun(now+0.025), fun(now), units="days")), 0.025, info = "Date.ctor.diff.0025")
46+
expect_equal(as.numeric(difftime(fun(now+0.250), fun(now), units="days")), 0.250, info = "Date.ctor.diff.0250")
47+
expect_equal(as.numeric(difftime(fun(now+2.500), fun(now), units="days")), 2.500, info = "Date.ctor.diff.2500")
48+
49+
# test.Date.ctor.mdy <- function() {
50+
expect_equal(ctor_mdy(), as.Date("2005-12-31"), info = "Date.ctor.mdy")
51+
52+
# test.Date.ctor.ymd <- function() {
53+
expect_equal(ctor_ymd(), as.Date("2005-12-31"), info = "Date.ctor.ymd")
54+
55+
# test.Date.ctor.int <- function() {
56+
fun <- ctor_int
57+
d <- as.Date("2005-12-31")
58+
expect_equal(fun(as.numeric(d)), d, info = "Date.ctor.int")
59+
expect_equal(fun(-1), as.Date("1970-01-01")-1, info = "Date.ctor.int")
60+
expect_error(fun("foo"), info = "Date.ctor -> exception" )
61+
62+
# test.Date.ctor.string <- function() {
63+
fun <- ctor_string
64+
dtstr <- "1991-02-03"
65+
dtfun <- fun(dtstr)
66+
dtstr <- as.Date(strptime(dtstr, "%Y-%m-%d"))
67+
ddstr <- as.Date(dtstr, "%Y-%m-%d")
68+
expect_equal(dtfun, dtstr, info = "Date.fromString.strptime")
69+
expect_equal(dtfun, ddstr, info = "Date.fromString.asDate")
70+
71+
# test.Date.operators <- function() {
72+
expect_equal(operators(),
73+
list(diff=-1, bigger=TRUE, smaller=FALSE, equal=FALSE, ge=TRUE, le=FALSE, ne=TRUE),
74+
info = "Date.operators")
75+
76+
77+
# test.Date.components <- function() {
78+
expect_equal(components(),
79+
list(day=31, month=12, year=2005, weekday=7, yearday=365),
80+
info = "Date.components")
81+
82+
# test.vector.Date <- function(){
83+
expect_equal(vector_Date(), rep(as.Date("2005-12-31"),2), info = "Date.vector.wrap")
84+
85+
# test.DateVector.wrap <- function(){
86+
expect_equal(Datevector_wrap(), rep(as.Date("2005-12-31"),2), info = "DateVector.wrap")
87+
88+
# test.DateVector.operator.SEXP <- function(){
89+
expect_equal(Datevector_sexp(), rep(as.Date("2005-12-31"),2), info = "DateVector.SEXP")
90+
91+
# test.Date.getFunctions <- function(){
92+
fun <- Date_get_functions
93+
expect_equal(fun(as.Date("2010-12-04")),
94+
list(year=2010, month=12, day=4, wday=7, yday=338), info = "Date.get.functions.1")
95+
expect_equal(fun(as.Date("2010-01-01")),
96+
list(year=2010, month=1, day=1, wday=6, yday=1), info = "Date.get.functions.2")
97+
expect_equal(fun(as.Date("2009-12-31")),
98+
list(year=2009, month=12, day=31, wday=5, yday=365), info = "Date.get.functions.3")
99+
100+
# test.Datetime.get.functions <- function() {
101+
fun <- Datetime_get_functions
102+
expect_equal(fun(as.numeric(as.POSIXct("2001-02-03 01:02:03.123456", tz="UTC"))),
103+
list(year=2001, month=2, day=3, wday=7, hour=1, minute=2, second=3, microsec=123456),
104+
info = "Datetime.get.functions")
105+
106+
# test.Datetime.operators <- function() {
107+
expect_equal(Datetime_operators(),
108+
list(diff=-60*60, bigger=TRUE, smaller=FALSE, equal=FALSE, ge=TRUE, le=FALSE, ne=TRUE),
109+
info = "Datetime.operators")
110+
111+
# test.Datetime.wrap <- function() {
112+
expect_equal(as.numeric(Datetime_wrap()), as.numeric(as.POSIXct("2001-02-03 01:02:03.123456", tz="UTC")),
113+
info = "Datetime.wrap")
114+
115+
# test.Datetime.fromString <- function() {
116+
fun <- Datetime_from_string
117+
dtstr <- "1991-02-03 04:05:06.789"
118+
dtfun <- fun(dtstr)
119+
dtstr <- as.POSIXct(strptime(dtstr, "%Y-%m-%d %H:%M:%OS"))
120+
expect_equal(as.numeric(dtfun), as.numeric(dtstr), info = "Datetime.fromString")
121+
122+
## TZ difference ...
123+
##test.Datetime.ctor <- function() {
124+
## fun <- .Rcpp.Date$Datetime_ctor_sexp
125+
## expect_equal(fun(1234567), as.POSIXct(1234567, origin="1970-01-01"), info = "Datetime.ctor.1")
126+
## expect_equal(fun(-120.25), as.POSIXct(-120.5, origin="1970-01-01"), info = "Datetime.ctor.2")
127+
## expect_equal(fun( 120.25), as.POSIXct( 120.25, origin="1970-01-01"), info = "Datetime.ctor.3")
128+
##}
129+
130+
# test.Datetime.ctor.notFinite <- function() {
131+
fun <- Datetime_ctor_sexp
132+
posixtNA <- as.POSIXct(NA, origin="1970-01-01")
133+
expect_equal(fun(NA), posixtNA, info = "Datetime.ctor.na")
134+
expect_equal(fun(NaN), posixtNA, info = "Datetime.ctor.nan")
135+
expect_equal(fun(Inf), posixtNA, info = "Datetime.ctor.inf")
136+
137+
# test.Datetime.ctor.diffs <- function() {
138+
fun <- Datetime_ctor_sexp
139+
now <- Sys.time()
140+
## first one is Ripley's fault as he decreed that difftime of POSIXct should stop at milliseconds
141+
expect_equal(round(as.numeric(difftime(fun(now+0.025), fun(now), units="sec")), digits=4), 0.025, info = "Datetime.ctor.diff.0025")
142+
expect_equal(as.numeric(difftime(fun(now+0.250), fun(now), units="sec")), 0.250, info = "Datetime.ctor.diff.0250")
143+
expect_equal(as.numeric(difftime(fun(now+2.500), fun(now), units="sec")), 2.500, info = "Datetime.ctor.diff.2500")
144+
145+
# test.DatetimeVector.ctor <- function() {
146+
fun <- DatetimeVector_ctor
147+
now <- Sys.time()
148+
expect_equal(fun(now + (0:4)*60), now+(0:4)*60, info = "Datetime.ctor.sequence")
149+
if (Rcpp:::capabilities()[["new date(time) vectors"]]) {
150+
vec <- c(now, NA, NaN, now+2.345)
151+
posixtNA <- as.POSIXct(NA, origin="1970-01-01")
152+
expect_equal(fun(vec), c(now, rep(posixtNA, 2), now+2.345), info = "Datetime.ctor.NA.NaN.set")
153+
vec <- c(now, -Inf, Inf, now+2.345)
154+
expect_equal(sum(is.finite(fun(vec))), 2, info = "Datetime.ctor.Inf.finite.set")
155+
expect_equal(sum(is.infinite(fun(vec))), 2, info = "Datetime.ctor.Inf.notfinite.set")
156+
vec <- c(now, NA, NaN, Inf, now+2.345)
157+
posixtNA <- as.POSIXct(NA, origin="1970-01-01")
158+
posixtInf <- as.POSIXct(Inf, origin="1970-01-01")
159+
expect_equal(fun(vec), c(now, rep(posixtNA, 2), posixtInf, now+2.345),
160+
info = "Datetime.ctor.NA.NaN.Inf.set")
161+
} else {
162+
vec <- c(now, NA, NaN, Inf, now+2.345)
163+
posixtNA <- as.POSIXct(NA, origin="1970-01-01")
164+
expect_equal(fun(vec), c(now, rep(posixtNA, 3), now+2.345), info = "Datetime.ctor.NA.NaN.Inf.set")
165+
}
166+
167+
168+
# test.DatetimeVector.assignment <- function() {
169+
now <- Sys.time()
170+
v1 <- c(now, now + 1, now + 2)
171+
v2 <- c(now + 3, now + 4, now + 5)
172+
expect_equal(v2, DatetimeVector_assignment(v1, v2))
173+
174+
# test.DateVector.assignment <- function() {
175+
now <- Sys.Date()
176+
v1 <- c(now, now + 1, now + 2)
177+
v2 <- c(now + 3, now + 4, now + 5)
178+
expect_equal(v2, DateVector_assignment(v1, v2))
179+
180+
## formatting
181+
# test.Date.formating <- function() {
182+
oldTZ <- Sys.getenv("TZ")
183+
if (oldTZ == "America/Chicago") {
184+
##Sys.setenv(TZ="America/Chicago")
185+
d <- as.Date("2011-12-13")
186+
187+
expect_equal(Date_format(d, "%Y-%m-%d"), format(d), info="Date.formating.default")
188+
expect_equal(Date_format(d, "%Y/%m/%d"), format(d, "%Y/%m/%d"), info="Date.formating.given.format")
189+
expect_equal(Date_ostream(d), format(d), info="Date.formating.ostream")
190+
##Sys.setenv(TZ=oldTZ)
191+
}
192+
193+
#test.Datetime.formating <- function() {
194+
olddigits <- getOption("digits.secs")
195+
options("digits.secs"=6)
196+
197+
d <- as.POSIXct("2016-12-13 14:15:16.123456")
198+
expect_equal(Datetime_format(d,"%Y-%m-%d %H:%M:%S"),
199+
format(d, "%Y-%m-%d %H:%M:%OS"),
200+
info="Datetime.formating.default")
201+
expect_equal(Datetime_format(d, "%Y/%m/%d %H:%M:%S"),
202+
format(d, "%Y/%m/%d %H:%M:%OS"),
203+
info="Datetime.formating.given.format")
204+
expect_equal(Datetime_ostream(d),
205+
format(d, "%Y-%m-%d %H:%M:%OS"),
206+
info="Datetime.formating.ostream")
207+
options("digits.secs"=olddigits)
208+
209+
210+
# test.mktime_gmtime <- function() {
211+
d <- as.Date("2015-12-31")
212+
expect_equal(d, gmtime_mktime(d), info="Date.mktime_gmtime.2015")
213+
214+
d <- as.Date("1965-12-31")
215+
expect_equal(d, gmtime_mktime(d), info="Date.mktime_gmtime.1965")
216+
217+
# test.mktime <- function() {
218+
d <- as.Date("2015-12-31")
219+
expect_equal(test_mktime(d), as.numeric(as.POSIXct(d)), info="Date.test_mktime.2015")
220+
221+
d <- as.Date("1970-01-01")
222+
expect_equal(test_mktime(d), as.numeric(as.POSIXct(d)), info="Date.test_mktime.1970")
223+
224+
d <- as.Date("1954-07-04")
225+
expect_equal(test_mktime(d), as.numeric(as.POSIXct(d)), info="Date.test_mktime.1954")
226+
227+
# test.gmtime <- function() {
228+
oldTZ <- Sys.getenv("TZ")
229+
if (oldTZ == "UTC") {
230+
##Sys.setenv(TZ="UTC")
231+
expect_equal(test_gmtime(1441065600), as.Date("2015-09-01"), info="Date.test_gmtime.2015")
232+
233+
expect_equal(test_gmtime(0), as.Date("1970-01-01"), info="Date.test_gmtime.1970")
234+
235+
expect_equal(test_gmtime(-489024000), as.Date("1954-07-04"), info="Date.test_gmtime.1954")
236+
##Sys.setenv(TZ=oldTZ)
237+
}
238+
239+
# test.NA <- function() {
240+
dv <- Sys.Date() + 0:2
241+
expect_true(has_na_dv(dv) == FALSE, info="DateVector.NAtest.withoutNA")
242+
dv[1] <- NA
243+
expect_true(has_na_dv(dv) == TRUE, info="DateVector.NAtest.withNA")
244+
245+
dvt <- Sys.time() + 0:2
246+
expect_true(has_na_dtv(dvt) == FALSE, info="DatetimeVector.NAtest.withoutNA")
247+
dvt[1] <- NA
248+
expect_true(has_na_dtv(dvt) == TRUE, info="DatetimeVector.NAtest.withNA")

0 commit comments

Comments
 (0)