[Pastecs-commits] r4 - in pkg: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Mar 18 14:56:20 CET 2010
Author: phgrosjean
Date: 2010-03-18 14:56:19 +0100 (Thu, 18 Mar 2010)
New Revision: 4
Modified:
pkg/DESCRIPTION
pkg/R/AutoD2.R
pkg/R/CenterD2.R
pkg/R/CrossD2.R
pkg/R/GetUnitText.R
pkg/R/buysbal.R
pkg/R/daystoyears.R
pkg/R/decaverage.R
pkg/R/deccensus.R
pkg/R/decdiff.R
pkg/R/decevf.R
pkg/R/decloess.R
pkg/R/decmedian.R
pkg/R/decreg.R
pkg/R/disto.R
pkg/R/escouf.R
pkg/R/extract.regul.R
pkg/R/extract.tsd.R
pkg/R/extract.turnogram.R
pkg/R/is.tseries.R
pkg/R/lines.abund.R
pkg/R/lines.escouf.R
pkg/R/local.trend.R
pkg/R/pgleissberg.R
pkg/R/plot.abund.R
pkg/R/plot.escouf.R
pkg/R/plot.tsd.R
pkg/R/plot.turnogram.R
pkg/R/regarea.R
pkg/R/regconst.R
pkg/R/reglin.R
pkg/R/regspline.R
pkg/R/regul.R
pkg/R/stat.desc.R
pkg/R/stat.pen.R
pkg/R/stat.slide.R
pkg/R/trend.test.R
pkg/R/tsd.R
pkg/R/tseries.R
pkg/R/turnogram.R
pkg/R/turnpoints.R
pkg/R/vario.R
pkg/R/yearstodays.R
pkg/man/AutoD2.Rd
pkg/man/GetUnitText.Rd
pkg/man/abund.Rd
pkg/man/bnr.Rd
pkg/man/buysbal.Rd
pkg/man/daystoyears.Rd
pkg/man/decaverage.Rd
pkg/man/deccensus.Rd
pkg/man/decdiff.Rd
pkg/man/decevf.Rd
pkg/man/decloess.Rd
pkg/man/decmedian.Rd
pkg/man/decreg.Rd
pkg/man/disjoin.Rd
pkg/man/disto.Rd
pkg/man/escouf.Rd
pkg/man/extract.Rd
pkg/man/first.Rd
pkg/man/gleissberg.table.Rd
pkg/man/is.tseries.Rd
pkg/man/last.Rd
pkg/man/local.trend.Rd
pkg/man/marbio.Rd
pkg/man/marphy.Rd
pkg/man/match.tol.Rd
pkg/man/pennington.Rd
pkg/man/pgleissberg.Rd
pkg/man/regarea.Rd
pkg/man/regconst.Rd
pkg/man/reglin.Rd
pkg/man/regspline.Rd
pkg/man/regul.Rd
pkg/man/regul.adj.Rd
pkg/man/regul.screen.Rd
pkg/man/releve.Rd
pkg/man/specs.Rd
pkg/man/stat.desc.Rd
pkg/man/stat.pen.Rd
pkg/man/stat.slide.Rd
pkg/man/trend.test.Rd
pkg/man/tsd.Rd
pkg/man/tseries.Rd
pkg/man/turnogram.Rd
pkg/man/turnpoints.Rd
pkg/man/vario.Rd
Log:
Clean up S-PLUS code, and bugs corrections in pgleissberg() and stat.desc()
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/DESCRIPTION 2010-03-18 13:56:19 UTC (rev 4)
@@ -1,10 +1,11 @@
Package: pastecs
Title: Package for Analysis of Space-Time Ecological Series
-Version: 1.3-7
-Date: 2008-05-24
+Version: 1.3-11
+Date: 2009-12-17
Author: Frederic Ibanez <ibanez at obs-vlfr.fr>, Philippe Grosjean <phgrosjean at sciviews.org> & Michele Etienne <etienne at obs-vlfr.fr>
Description: Regulation, decomposition and analysis of space-time series. The pastecs library is a PNEC-Art4 and IFREMER (Benoit Beliaeff <Benoit.Beliaeff at ifremer.fr>) initiative to bring PASSTEC 2000 (http://www.obs-vlfr.fr/~enseigne/anado/passtec/passtec.htm) functionnalities to R.
URL: http://www.sciviews.org/pastecs
+Encoding: latin1
Maintainer: Philippe Grosjean <phgrosjean at sciviews.org>
-License: GNU Public Licence 2.0 or above at your convenience
+License: GPL (>= 2)
Depends: boot, stats
\ No newline at end of file
Modified: pkg/R/AutoD2.R
===================================================================
--- pkg/R/AutoD2.R 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/R/AutoD2.R 2010-03-18 13:56:19 UTC (rev 4)
@@ -2,15 +2,9 @@
function(series, lags=c(1, nrow(series)/3), step=1, plotit=TRUE, add=FALSE,...) {
call <- match.call()
data <- deparse(substitute(series))
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- # Now done with Depends: field require(stats)
- if (is.null(class(series)) || class(series)[1] != "mts")
- stop("series must be a multiple regular time series object")
- Unit <- attr(series, "units")
- } else {
- # Rem: cannot test if it is a time series
- Unit <- attr(attr(series, "tspar"), "units")
- }
+ if (is.null(class(series)) || class(series)[1] != "mts")
+ stop("series must be a multiple regular time series object")
+ Unit <- attr(series, "units")
UnitTxt <- GetUnitText(series)
# Test the length of the series, range and step...
n <- nrow(series)
Modified: pkg/R/CenterD2.R
===================================================================
--- pkg/R/CenterD2.R 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/R/CenterD2.R 2010-03-18 13:56:19 UTC (rev 4)
@@ -2,15 +2,9 @@
function(series, window=nrow(series)/5, plotit=TRUE, add=FALSE, type="l", level=0.05, lhorz=TRUE, lcol=2, llty=2,...) {
call <- match.call()
data <- deparse(substitute(series))
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- # Now done with Depends: field require(stats)
- if (is.null(class(series)) || class(series)[1] != "mts")
- stop("series must be a multiple regular time series object")
- Unit <- attr(series, "units")
- } else {
- # Rem: cannot test if it is a time series
- Unit <- attr(attr(series, "tspar"), "units")
- }
+ if (is.null(class(series)) || class(series)[1] != "mts")
+ stop("series must be a multiple regular time series object")
+ Unit <- attr(series, "units")
UnitTxt <- GetUnitText(series)
# Test the length of the serie, range and step...
n <- nrow(series)
Modified: pkg/R/CrossD2.R
===================================================================
--- pkg/R/CrossD2.R 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/R/CrossD2.R 2010-03-18 13:56:19 UTC (rev 4)
@@ -3,18 +3,12 @@
call <- match.call()
data1 <- deparse(substitute(series))
data2 <- deparse(substitute(series2))
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- # Now done with Depends: field require(stats)
- if (is.null(class(series)) || class(series)[1] != "mts")
- stop("series must be a multiple regular time series object")
- if (is.null(class(series2)) || class(series2)[1] != "mts")
- stop("series2 must be a multiple regular time series object")
-
- Unit <- attr(series, "units")
- } else {
- # Rem: cannot test if these are multiple time series
- Unit <- attr(attr(series, "tspar"), "units")
- }
+ if (is.null(class(series)) || class(series)[1] != "mts")
+ stop("series must be a multiple regular time series object")
+ if (is.null(class(series2)) || class(series2)[1] != "mts")
+ stop("series2 must be a multiple regular time series object")
+
+ Unit <- attr(series, "units")
if (nrow(series) != nrow(series2))
stop("series and series2 must have same row number")
if (ncol(series) != ncol(series2))
Modified: pkg/R/GetUnitText.R
===================================================================
--- pkg/R/GetUnitText.R 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/R/GetUnitText.R 2010-03-18 13:56:19 UTC (rev 4)
@@ -1,10 +1,6 @@
"GetUnitText" <-
function(series) {
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- Unit <- attr(series, "units")
- } else {
- Unit <- attr(attr(series, "tspar"), "units") # In Splus, "units" is an attribute of "tspar"!!!
- }
+ Unit <- attr(series, "units")
frequency <- frequency(series)
deltat <- deltat(series)
if (frequency == 1) pre <- "" else {
@@ -14,44 +10,23 @@
}
if (is.null(Unit)) UnitTxt <- "" else {
# Make sure unit is correctly spelled
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- # Rem: R v. 1.4.0 add casefold(), but 1.3.1 has only tolower()!!!
- if (tolower(Unit) == "years") Unit <- "years"
- if (tolower(Unit) == "year") Unit <- "years"
- if (tolower(Unit) == "y") Unit <- "years"
- if (tolower(Unit) == "weeks") Unit <- "weeks"
- if (tolower(Unit) == "week") Unit <- "weeks"
- if (tolower(Unit) == "days") Unit <- "days"
- if (tolower(Unit) == "day") Unit <- "days"
- if (tolower(Unit) == "d") Unit <- "days"
- if (tolower(Unit) == "hours") Unit <- "hours"
- if (tolower(Unit) == "hour") Unit <- "hours"
- if (tolower(Unit) == "h") Unit <- "hours"
- if (tolower(Unit) == "minutes") Unit <- "min"
- if (tolower(Unit) == "minute") Unit <- "min"
- if (tolower(Unit) == "min") Unit <- "min"
- if (tolower(Unit) == "secondes") Unit <- "sec"
- if (tolower(Unit) == "seconde") Unit <- "sec"
- if (tolower(Unit) == "sec") Unit <- "sec"
- } else { # We are in Splus
- if (casefold(Unit) == "years") Unit <- "years"
- if (casefold(Unit) == "year") Unit <- "years"
- if (casefold(Unit) == "y") Unit <- "years"
- if (casefold(Unit) == "weeks") Unit <- "weeks"
- if (casefold(Unit) == "week") Unit <- "weeks"
- if (casefold(Unit) == "days") Unit <- "days"
- if (casefold(Unit) == "day") Unit <- "days"
- if (casefold(Unit) == "d") Unit <- "days"
- if (casefold(Unit) == "hours") Unit <- "hours"
- if (casefold(Unit) == "hour") Unit <- "hours"
- if (casefold(Unit) == "h") Unit <- "hours"
- if (casefold(Unit) == "minutes") Unit <- "min"
- if (casefold(Unit) == "minute") Unit <- "min"
- if (casefold(Unit) == "min") Unit <- "min"
- if (casefold(Unit) == "secondes") Unit <- "sec"
- if (casefold(Unit) == "seconde") Unit <- "sec"
- if (casefold(Unit) == "sec") Unit <- "sec"
- }
+ if (tolower(Unit) == "years") Unit <- "years"
+ if (tolower(Unit) == "year") Unit <- "years"
+ if (tolower(Unit) == "y") Unit <- "years"
+ if (tolower(Unit) == "weeks") Unit <- "weeks"
+ if (tolower(Unit) == "week") Unit <- "weeks"
+ if (tolower(Unit) == "days") Unit <- "days"
+ if (tolower(Unit) == "day") Unit <- "days"
+ if (tolower(Unit) == "d") Unit <- "days"
+ if (tolower(Unit) == "hours") Unit <- "hours"
+ if (tolower(Unit) == "hour") Unit <- "hours"
+ if (tolower(Unit) == "h") Unit <- "hours"
+ if (tolower(Unit) == "minutes") Unit <- "min"
+ if (tolower(Unit) == "minute") Unit <- "min"
+ if (tolower(Unit) == "min") Unit <- "min"
+ if (tolower(Unit) == "secondes") Unit <- "sec"
+ if (tolower(Unit) == "seconde") Unit <- "sec"
+ if (tolower(Unit) == "sec") Unit <- "sec"
UnitTxt <- paste(pre, Unit, sep="")
# Select some particular cases
if (Unit == "years" & frequency == 12) UnitTxt <- "months"
Modified: pkg/R/buysbal.R
===================================================================
--- pkg/R/buysbal.R 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/R/buysbal.R 2010-03-18 13:56:19 UTC (rev 4)
@@ -14,8 +14,6 @@
x <- as.vector(x)
y <- as.vector(y)
} else { # We must have a time series in x
- # Require a library in R
- # Now done with Depends: field if (exists("is.R") && is.function(is.R) && is.R()) require(stats)
if (!is.tseries(x))
stop("x must be a regular time series if y is not provided")
y <- as.vector(x)
Modified: pkg/R/daystoyears.R
===================================================================
--- pkg/R/daystoyears.R 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/R/daystoyears.R 2010-03-18 13:56:19 UTC (rev 4)
@@ -2,57 +2,48 @@
function (x, datemin=NULL, dateformat="m/d/Y") {
x <- x
datemin <- datemin
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R,
- defyearorig <- 1970
- # In R, we use POSIXt
- if (length(datemin) > 0 && !any(class(datemin) == "POSIXt")) { # We must convert
- # To be compatible with chron() and with Splus, we accept format as "d/m/y"
- # which is converted into %d/%m/%y. Warning! Still must make difference between
- # "y" that corresponds to year in "89" and "Y" for full-spelled years in "1989"!!!
- # make necessary conversions to accept old formats
- dateformat <- sub("month", "%B", dateformat) # Full spelled month
- dateformat <- sub("mon", "%b", dateformat) # Abbreviated month
- dateformat <- sub("m", "%m", dateformat) # month - numeric
- dateformat <- sub("d", "%d", dateformat) # day
- dateformat <- sub("y", "%y", dateformat) # year (two digits)
- dateformat <- sub("Y", "%Y", dateformat) # Year (four digits)
- datemin <- strptime(as.character(datemin), format=dateformat)
- }
- # Julian is adapted from julian.default in lib chron 2.2-19 (this way we don't require chron!)
- "Julian" <- function(x, d, y) {
- if(is.null(origin. <- getOption("chron.origin")))
- origin. <- c(month = 1, day = 1, year = 1970) # Default origin in R
- m <- c(origin.[1], x) # prepend month of new origin
- d <- c(origin.[2], d) # prepend day of new origin
- y <- c(origin.[3], y) # prepend year of new origin
- # code from julian date in the S book (p.269)
- y <- y + ifelse(m > 2, 0, -1)
- m <- m + ifelse(m > 2, -3, 9)
- c <- y %/% 100
- ya <- y - 100 * c
- out <- ((146097 * c) %/% 4 + (1461 * ya) %/% 4 + (153 * m + 2) %/% 5 + d + 1721119)
- ## now subtract the new origin from all dates
- if(all(origin. == 0))
- out <- out[-1]
- else
- out <- out[-1] - out[1]
- # orig according to S algorithm
- out
- }
-
- if (length(datemin) > 0) {
- dateminval <- Julian(datemin$mon+1, datemin$mday, datemin$year+1900)
- # now we shift the whole x series so as the minimal day matches dateminval
- x <- x - trunc(min(x, na.rm=TRUE)) + dateminval
- }
- } else { # We are in Splus
- defyearorig <- 1960
- if (length(datemin) > 0) {
- dateminval <- as.numeric(chron(datemin, "00:00:00", format=c(dateformat, "h:m:s")))
- # now we shift the whole x series so as the minimal day matches dateminval
- x <- x - trunc(min(x, na.rm=TRUE)) + dateminval
- }
+ defyearorig <- 1970
+ # In R, we use POSIXt
+ if (length(datemin) > 0 && !any(class(datemin) == "POSIXt")) { # We must convert
+ # To be compatible with chron() and with Splus, we accept format as "d/m/y"
+ # which is converted into %d/%m/%y. Warning! Still must make difference between
+ # "y" that corresponds to year in "89" and "Y" for full-spelled years in "1989"!!!
+ # make necessary conversions to accept old formats
+ dateformat <- sub("month", "%B", dateformat) # Full spelled month
+ dateformat <- sub("mon", "%b", dateformat) # Abbreviated month
+ dateformat <- sub("m", "%m", dateformat) # month - numeric
+ dateformat <- sub("d", "%d", dateformat) # day
+ dateformat <- sub("y", "%y", dateformat) # year (two digits)
+ dateformat <- sub("Y", "%Y", dateformat) # Year (four digits)
+ datemin <- strptime(as.character(datemin), format=dateformat)
}
+ # Julian is adapted from julian.default in lib chron 2.2-19 (this way we don't require chron!)
+ "Julian" <- function(x, d, y) {
+ if(is.null(origin. <- getOption("chron.origin")))
+ origin. <- c(month = 1, day = 1, year = 1970) # Default origin in R
+ m <- c(origin.[1], x) # prepend month of new origin
+ d <- c(origin.[2], d) # prepend day of new origin
+ y <- c(origin.[3], y) # prepend year of new origin
+ # code from julian date in the S book (p.269)
+ y <- y + ifelse(m > 2, 0, -1)
+ m <- m + ifelse(m > 2, -3, 9)
+ c <- y %/% 100
+ ya <- y - 100 * c
+ out <- ((146097 * c) %/% 4 + (1461 * ya) %/% 4 + (153 * m + 2) %/% 5 + d + 1721119)
+ ## now subtract the new origin from all dates
+ if(all(origin. == 0))
+ out <- out[-1]
+ else
+ out <- out[-1] - out[1]
+ # orig according to S algorithm
+ out
+ }
+
+ if (length(datemin) > 0) {
+ dateminval <- Julian(datemin$mon+1, datemin$mday, datemin$year+1900)
+ # now we shift the whole x series so as the minimal day matches dateminval
+ x <- x - trunc(min(x, na.rm=TRUE)) + dateminval
+ }
# We have days as units. We want years with a "linear scale", i.e.: 1 year = 365.25 days, 1 month = 1/12 years
# We want also the integer value reflect exactly the current year, i.e.: 1997.xxx for dates in the year 1997
if(is.null(yearorig <- options("chron.origin")$year))
Modified: pkg/R/decaverage.R
===================================================================
--- pkg/R/decaverage.R 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/R/decaverage.R 2010-03-18 13:56:19 UTC (rev 4)
@@ -1,13 +1,9 @@
"decaverage" <-
function(x, type="additive", order=1, times=1, sides=2, ends="fill", weights=NULL) {
call <- match.call()
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- x <- as.ts(x)
- } else { # We are in S+
- x <- as.rts(x)
- }
- if (is.matrix(x) && ncol(x) != 1)
- stop("only univariate series are allowed")
+ x <- as.ts(x)
+ if (is.matrix(x) && ncol(x) != 1)
+ stop("only univariate series are allowed")
if (!is.numeric(times) || times <= 0)
stop("times must be a positive number")
if (!is.numeric(sides) || (sides != 1 & sides != 2))
@@ -64,11 +60,7 @@
# create our own specs component
specs <- list(method="average", type=type, order=order, times=times, sides=sides, ends=ends, weights=weights)
# we recuperate units from x
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- units <- attr(x, "units")
- } else {
- units <- attr(attr(x, "tspar"), "units")
- }
+ units <- attr(x, "units")
# We define functions that pads elements at end of the vector
padmean <- function(x, order, sides) {
n <- length(x)
@@ -125,8 +117,6 @@
res
}
n <- length(x)
- if (exists("is.R") && is.function(is.R) && is.R()) # We are in R
- # Now done with Depends: field require(stats)
filtered <- x # We don't change the initial series, but a copy of it
filt <- weights/sum(weights) # Scale down weights
for (i in 1:times) {
@@ -141,15 +131,9 @@
# perform filtering
filtered <- filter(padx$x, filter=filt, method="convolution", sides=sides, circular=circular)
# Now we have to cut the vector x according to cut (we don't use the function window for that since we didn't changed tspar!)
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- filtered <- as.ts(as.vector(filtered)[cut[1]:cut[2]])
- tsp(filtered) <- tsp(x)
- filtered<- as.ts(filtered)
- } else { # We are in S+
- filtered <- as.rts(as.vector(filtered)[cut[1]:cut[2]])
- tspar(filtered) <- tspar(x)
- filtered <- as.rts(filtered)
- }
+ filtered <- as.ts(as.vector(filtered)[cut[1]:cut[2]])
+ tsp(filtered) <- tsp(x)
+ filtered<- as.ts(filtered)
}
# Calculate residuals
if (type == "additive") {
Modified: pkg/R/deccensus.R
===================================================================
--- pkg/R/deccensus.R 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/R/deccensus.R 2010-03-18 13:56:19 UTC (rev 4)
@@ -2,13 +2,8 @@
function(x, type="multiplicative", trend=FALSE) { # Only the multiplicative model is allowed. Use loess for an additive seasonal decomposition
# But here we also offer the possibility of using an additive model
call <- match.call()
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- # Now done with Depends: field require(stats)
- x <- as.ts(x)
- } else { # We are in S+
- x <- as.rts(x)
- }
- if (is.matrix(x) && ncol(x) != 1)
+ x <- as.ts(x)
+ if (is.matrix(x) && ncol(x) != 1)
stop("only univariate series are allowed")
# Check the type argument
TYPES <- c("additive", "multiplicative")
@@ -26,11 +21,7 @@
# create our own specs component
specs <- list(method="census", type=type)
# we recuperate units from x
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- units <- attr(x, "units")
- } else {
- units <- attr(attr(x, "tspar"), "units")
- }
+ units <- attr(x, "units")
# perform filtering
n <- length(x)
period <- frequency(x)
@@ -191,34 +182,18 @@
Amp <- sum(abs(I1[2:n] - I1[1:(n-1)]))/(n-1)
# Concatenate series
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- if (trend == FALSE) {
- S <- as.ts(S)
- tsp(S) <- tsp(CI)
- series <- ts.union(CI, S/100)
- dimnames(series)[[2]] <- c("deseasoned", "seasonal")
- } else {
- S <- as.ts(S)
- tsp(S) <- tsp(I)
- C <- as.ts(C)
- tsp(C) <- tsp(I)
- series <- ts.union(C, S/100, I/100)
- dimnames(series)[[2]] <- c("trend", "seasonal", "residuals")
- }
- } else{ # We are in S+
- if (trend == FALSE) {
- S <- as.rts(S)
- tspar(S) <- tspar(CI)
- series <- ts.union(CI, S/100)
- dimnames(series)[[2]] <- c("deseasoned", "seasonal")
- } else {
- S <- as.rts(S)
- tspar(S) <- tspar(I)
- C <- as.rts(C)
- tspar(C) <- tspar(I)
- series <- ts.union(C, S/100, I/100)
- dimnames(series)[[2]] <- c("trend", "seasonal", "residuals")
- }
+ if (trend == FALSE) {
+ S <- as.ts(S)
+ tsp(S) <- tsp(CI)
+ series <- ts.union(CI, S/100)
+ dimnames(series)[[2]] <- c("deseasoned", "seasonal")
+ } else {
+ S <- as.ts(S)
+ tsp(S) <- tsp(I)
+ C <- as.ts(C)
+ tsp(C) <- tsp(I)
+ series <- ts.union(C, S/100, I/100)
+ dimnames(series)[[2]] <- c("trend", "seasonal", "residuals")
}
}
}
Modified: pkg/R/decdiff.R
===================================================================
--- pkg/R/decdiff.R 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/R/decdiff.R 2010-03-18 13:56:19 UTC (rev 4)
@@ -1,11 +1,7 @@
"decdiff" <-
function(x, type="additive", lag=1, order=1, ends="fill") {
call <- match.call()
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- x <- as.ts(x)
- } else { # We are in S+
- x <- as.rts(x)
- }
+ x <- as.ts(x)
if (is.matrix(x) && ncol(x) != 1)
stop("only univariate series are allowed")
if (!is.numeric(lag) || lag <= 0)
@@ -38,21 +34,11 @@
# create our own specs component
specs <- list(method="diff", type=type, lag=lag, order=order, ends=ends)
# we recuperate units from x
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- units <- attr(x, "units")
- } else {
- units <- attr(attr(x, "tspar"), "units")
- }
- if (exists("is.R") && is.function(is.R) && is.R()) # We are in R
- # Now done with Depends: field require(stats)
+ units <- attr(x, "units")
# The next function add enough data to the left (either NA or the mean of first few values)
# to obtain a series of the same length as x after difference
padleft <- function(x, Lag, fill) {
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- x <- window(x, start=start(lag(x, Lag)), end=end(x), extend=TRUE)
- } else { # We are in S+
- x <- ts.union(lag(x, Lag), x)[,2]
- }
+ x <- window(x, start=start(lag(x, Lag)), end=end(x), extend=TRUE)
if (fill == TRUE) # We fill padded data with the mean of first few values
x[1:Lag] <- mean(x[(1:Lag)+Lag], na.rm=TRUE)
x
Modified: pkg/R/decevf.R
===================================================================
--- pkg/R/decevf.R 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/R/decevf.R 2010-03-18 13:56:19 UTC (rev 4)
@@ -1,11 +1,6 @@
"decevf" <-
function(x, type="additive", lag=5, axes=1:2) {
- call <- match.call()
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- x <- as.ts(x)
- } else { # We are in S+
- x <- as.rts(x)
- }
+ x <- as.ts(x)
if (is.matrix(x) && ncol(x) != 1)
stop("only univariate series are allowed")
if (!is.numeric(axes) || any(axes <= 0))
@@ -26,22 +21,10 @@
# create our own specs component
specs <- list(method="evf", type=type, lag=lag, axes=axes)
# we recuperate units from x
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- units <- attr(x, "units")
- } else {
- units <- attr(attr(x, "tspar"), "units")
- }
+ units <- attr(x, "units")
# perform filtering
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- # Now done with Depends: field require(stats)
- # Create the matrix with lagged series from 0 to lag
- xlagmat <- embed(x, lag)
- } else { # We are in S+
- x2 <- as.vector(x)
- n <- length(x2)
- m <- n - lag + 1
- xlagmat <- matrix(x2[1:m + rep(lag:1, rep(m, lag)) - 1], m)
- }
+ # Create the matrix with lagged series from 0 to lag
+ xlagmat <- embed(x, lag)
# Perform a pca decomposition of this matrix
x.pca <- princomp(xlagmat)
# Rotated vectors are obtained by:
@@ -60,16 +43,7 @@
xmat.recalc[1:n+(lag-i), i] <- xlagmat.recalc[,i]
# perform column means to get filtered time series
filtered <- apply(xmat.recalc, 1, mean, na.rm=TRUE)
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- filtered <- ts(filtered, start=start(x), frequency=frequency(x))
- } else { # We are in S+
- filtered <- rts(filtered, start=start(x), frequency=frequency(x))
- }
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- # Now done with Depends: field require(stats)
- } else { # We are in S+
- attr(filtered, "tspar") <- attr(x, "tspar") # This is to avoid a warning under S+
- }
+ filtered <- ts(filtered, start=start(x), frequency=frequency(x))
# Calculate residuals
if (type == "additive") {
residuals <- x - filtered
Modified: pkg/R/decloess.R
===================================================================
--- pkg/R/decloess.R 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/R/decloess.R 2010-03-18 13:56:19 UTC (rev 4)
@@ -2,11 +2,7 @@
function(x, type="additive", s.window=NULL, s.degree=0, t.window=NULL, t.degree=2, robust=FALSE, trend=FALSE) {
# loess allows only an additive model
call <- match.call()
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- x <- as.ts(x)
- } else { # We are in S+
- x <- as.rts(x)
- }
+ x <- as.ts(x)
if (is.matrix(x))
stop("only univariate series are allowed")
# Check the type argument
@@ -28,39 +24,18 @@
# create our own specs component
specs <- list(method="loess", type=type, s.window=s.window, s.degree=s.degree, t.window=t.window, t.degree=t.degree, robust=robust, trend=trend)
# we recuperate units from x
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- units <- attr(x, "units")
- } else {
- units <- attr(attr(x, "tspar"), "units")
- }
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- # Now done with Depends: field require(stats)
- if (t.degree == 2) t.degree <- 1 # Only 0 or 1 for R
- res.stl <- stl(x, s.window=s.window, s.degree=s.degree, t.window=t.window, t.degree=t.degree, robust=robust)
- if (trend == TRUE) {
- series <- cbind(res.stl$time.series[, "trend"], res.stl$time.series[, "seasonal"], res.stl$time.series[, "remainder"])
- dimnames(series)[[2]] <- c("trend", "seasonal", "residuals")
- } else { # residuals is trend + remainder in the additive model (otherwise, we recalculate them)
- series <- cbind(res.stl$time.series[, "trend"] + res.stl$time.series[, "remainder"], res.stl$time.series[, "seasonal"])
- dimnames(series)[[2]] <- c("deseasoned", "seasonal")
- }
- # create our own 'tsd' structure
- res <- list(ts="series", series=series, weights=res.stl$weights, units=units, specs=specs, call=call)
- } else { # We are in S+
- if (trend == TRUE)
- warning("S+ cannot calculate trend with this method!")
- if (t.degree == 0) t.degree <- 1 # Only 1 or 2 for S+
- res.stl <- stl(x, ss.window=s.window, ss.degree=s.degree, s.window=t.window, s.degree=t.degree, ss.robust=robust)
- deseasoned <- as.rts(res.stl$remainder)
- if (type == "additive") { # This is the way residuals are returned in S+
- seasonal <- as.rts(res.stl$seasonal)
- } else { # We have to recalculate them
- seasonal <- x / deseasoned
- }
- series <- ts.union(deseasoned, seasonal)
- # create our own 'tsd' structure
- res <- list(ts="series", series=series, weights=res.stl$weights, units=units, specs=specs, call=call)
- }
+ units <- attr(x, "units")
+ if (t.degree == 2) t.degree <- 1 # Only 0 or 1 for R
+ res.stl <- stl(x, s.window=s.window, s.degree=s.degree, t.window=t.window, t.degree=t.degree, robust=robust)
+ if (trend == TRUE) {
+ series <- cbind(res.stl$time.series[, "trend"], res.stl$time.series[, "seasonal"], res.stl$time.series[, "remainder"])
+ dimnames(series)[[2]] <- c("trend", "seasonal", "residuals")
+ } else { # residuals is trend + remainder in the additive model (otherwise, we recalculate them)
+ series <- cbind(res.stl$time.series[, "trend"] + res.stl$time.series[, "remainder"], res.stl$time.series[, "seasonal"])
+ dimnames(series)[[2]] <- c("deseasoned", "seasonal")
+ }
+ # create our own 'tsd' structure
+ res <- list(ts="series", series=series, weights=res.stl$weights, units=units, specs=specs, call=call)
class(res) <- "tsd" # change the class of the object to 'tsd'
res
}
Modified: pkg/R/decmedian.R
===================================================================
--- pkg/R/decmedian.R 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/R/decmedian.R 2010-03-18 13:56:19 UTC (rev 4)
@@ -1,11 +1,7 @@
"decmedian" <-
function(x, type="additive", order=1, times=1, ends="fill") {
call <- match.call()
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- x <- as.ts(x)
- } else { # We are in S+
- x <- as.rts(x)
- }
+ x <- as.ts(x)
if (is.matrix(x) && ncol(x) != 1)
stop("only univariate series are allowed")
if (!is.numeric(order) || order <= 0)
@@ -38,11 +34,7 @@
# create our own specs component
specs <- list(method="median", type=type, order=order, times=times, ends=ends)
# we recuperate units from x
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- units <- attr(x, "units")
- } else {
- units <- attr(attr(x, "tspar"), "units")
- }
+ units <- attr(x, "units")
# perform filtering
filtmedian <- function(x, n, order, term, na.rm) {
X <- NULL
@@ -66,8 +58,6 @@
} else {
residuals <- x / filtered
}
- #if (exists("is.R") && is.function(is.R) && is.R()) # We are in R
- # Now done with Depends: field require(stats)
series <- ts.union(filtered, residuals)
# create our own 'tsd' structure
res <- list(ts="series", series=series, units=units, specs=specs, call=call)
Modified: pkg/R/decreg.R
===================================================================
--- pkg/R/decreg.R 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/R/decreg.R 2010-03-18 13:56:19 UTC (rev 4)
@@ -5,20 +5,11 @@
stop("only univariate series are allowed")
if (length(x) != length(xreg))
stop("x and xreg must have same row number")
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- # Now done with Depends: field require(stats)
- x <- as.ts(x)
- xreg <- as.ts(xreg)
- # Make sure "tsp" attributes are the same for both series
- attr(xreg, "tsp") <- attr(x, "tsp")
- # stop("time series must have same time scale")
- } else { # We are in S+
- x <- as.rts(x)
- xreg <- as.rts(xreg)
- # Make sure "tspar" attributes are the same for both series
- attr(xreg, "tspar") <- attr(x, "tspar")
- }
- # Check the type argument
+ x <- as.ts(x)
+ xreg <- as.ts(xreg)
+ # Make sure "tsp" attributes are the same for both series
+ attr(xreg, "tsp") <- attr(x, "tsp")
+ # Check the type argument
TYPES <- c("additive", "multiplicative")
typeindex <- pmatch(type, TYPES)
if (is.na(typeindex))
@@ -32,11 +23,7 @@
# create our own specs component
specs <- list(method="reg", type=type, xreg=xreg)
# we recuperate units from x
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- units <- attr(x, "units")
- } else {
- units <- attr(attr(x, "tspar"), "units")
- }
+ units <- attr(x, "units")
model <- xreg
# Calculate residuals
if (type == "additive") {
Modified: pkg/R/disto.R
===================================================================
--- pkg/R/disto.R 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/R/disto.R 2010-03-18 13:56:19 UTC (rev 4)
@@ -3,8 +3,6 @@
if (is.null(disto.data)) { # Calculate distogram
call <- match.call()
data <- deparse(substitute(x))
- #if (exists("is.R") && is.function(is.R) && is.R()) # We are in R
- # Now done with Depends: field require(stats)
x <- as.matrix(x)
if (is.null(ncol(x)) || ncol(x) < 2)
stop("There must be at least two columns (series) in the dataset")
Modified: pkg/R/escouf.R
===================================================================
--- pkg/R/escouf.R 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/R/escouf.R 2010-03-18 13:56:19 UTC (rev 4)
@@ -41,8 +41,7 @@
if (verbose==TRUE) {
vrStr <- format(c(vr[i], 111))[1]
cat("Variable", vrStr, "incorporated, RV =", Rvmax, "\n")
- if (exists("is.R") && is.function(is.R) && is.R() && R.Version()$os == "Win32") { # We are in R Windows
- flush.console()}
+ flush.console()
}
if (Rvmax>level) break # Stop iteration (level reached)
}
Modified: pkg/R/extract.regul.R
===================================================================
--- pkg/R/extract.regul.R 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/R/extract.regul.R 2010-03-18 13:56:19 UTC (rev 4)
@@ -18,13 +18,8 @@
} else { # Use series to determine which series to extract
y <- as.matrix(e$y)[, series]
}
- # The treatment is different in R and in S+
- # In R, we create a 'ts' object, in S+, we create a 'rts' object
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- res <- ts(y, start=e$tspar$start, frequency=e$tspar$frequency)
- attr(res, "units") <- e$units
- } else { # We are in S+
- res <- rts(y, start=e$tspar$start, frequency=e$tspar$frequency, units=e$units)
- }
+ # We create a 'ts' object
+ res <- ts(y, start = e$tspar$start, frequency = e$tspar$frequency)
+ attr(res, "units") <- e$units
res
}
Modified: pkg/R/extract.tsd.R
===================================================================
--- pkg/R/extract.tsd.R 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/R/extract.tsd.R 2010-03-18 13:56:19 UTC (rev 4)
@@ -79,12 +79,7 @@
stop("nothing to extract!")
dimnames(res)[[2]] <- cnames
}
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- res <- as.ts(res)
- attr(res, "units") <- e$units
- } else { # We are in S+
- res <- as.rts(res)
- attr(attr(res, "tspar"), "units") <- e$units
- }
+ res <- as.ts(res)
+ attr(res, "units") <- e$units
res
}
Modified: pkg/R/extract.turnogram.R
===================================================================
--- pkg/R/extract.turnogram.R 2008-05-24 13:48:50 UTC (rev 3)
+++ pkg/R/extract.turnogram.R 2010-03-18 13:56:19 UTC (rev 4)
@@ -1,33 +1,18 @@
"extract.turnogram" <-
function(e, n, level=e$level, FUN=e$fun, drop=0, ...) {
if (missing(n)) n <- NULL
- if (exists("is.R") && is.function(is.R) && is.R()) { # We are in R
- data <- as.ts(eval(parse(text=e$data)))
- data <- window(data, start=start(data) + drop)
- if (level == 1) { # Simply return the original time series
- res <- data
- } else {
- if (is.null(n) || n > length(data)) n <- length(data)
-
- # Check the validity of level
- if (level < 1 || level > n/3) stop("level must be a value between 1 and n/3!")
- res <- aggregate(data, nfrequency=frequency(data)/level, FUN=FUN)
- }
- if (NROW(res) < 10)
- warning("The extracted series contains very few data (n < 10)")
- } else { # We are in S+
- data <- as.rts(eval(parse(text=e$data)))
- data <- window(data, start=start(data) + drop)
- if (level == 1) { # Simply return the original time series
- res <- data
- } else {
- if (is.null(n) || n > length(data)) n <- length(data)
- # Check the validity of level
- if (level < 1 || level > n/3) stop("level must be a value between 1 and n/3!")
- res <- aggregate(data, nf=frequency(data)/level, fun=FUN)
- }
- if (length(res) < 10)
- warning("The extracted series contains very few data (n < 10)")
+ data <- as.ts(eval(parse(text=e$data)))
+ data <- window(data, start=start(data) + drop)
+ if (level == 1) { # Simply return the original time series
+ res <- data
+ } else {
+ if (is.null(n) || n > length(data)) n <- length(data)
+
+ # Check the validity of level
+ if (level < 1 || level > n/3) stop("level must be a value between 1 and n/3!")
+ res <- aggregate(data, nfrequency=frequency(data)/level, FUN=FUN)
}
+ if (NROW(res) < 10)
+ warning("The extracted series contains very few data (n < 10)")
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/pastecs -r 4
More information about the Pastecs-commits
mailing list