Nothing
#
# This program 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.
#
# This program 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.
#
# A copy of the GNU General Public License is available at
# ../../COPYING
###############################################################################
# FUNCTION: DESCRIPTION:
# .xtplot.timeSeries Plots a 'timeSeries' object
# ... support for at = c("pretty", "chic")
###############################################################################
# FUNCTION: DESCRIPTION:
# .xtsPlot Internal xts plot unitility
# .axTicksByTime2 Takes care of "chic" axis creation
# .endpoints2 ... determines appropriate axis end points
# .periodicity2 ... determines appropriate axis periodicity
# .colorwheelPalette
###############################################################################
# .plot.timeSeries <-
# function(
# x, y, FinCenter = NULL,
# plot.type = c("multiple", "single"),
# format = "auto", at = pretty(x),
# widths = 1, heights = 1,
# xy.labels, xy.lines, panel = lines, nc, yax.flip = FALSE,
# mar.multi = c(0, 5.1, 0, if (yax.flip) 5.1 else 2.1),
# oma.multi = c(6, 0, 5, 0), axes = TRUE, ...)
# x=dummyMonthlySeries(); y = NULL; FinCenter = NULL; plot.type = "s"
# format = "auto"; at = "pretty"; panel = lines; yax.flip = FALSE
# mar.multi = c(0, 5.1, 0, if (yax.flip) 5.1 else 2.1)
# oma.multi = c(7.75, 1.1, 6.1, 1.1)
# dots <- list()
# y = NULL; FinCenter = NULL
# plot.type = c("single", "multiple")
# format = "auto"; at = c("pretty", "chic")
# panel = lines; yax.flip = FALSE
# mar.multi = c(0, 5.1, 0, if (yax.flip) 5.1 else 2.1)
# oma.multi = c(7.75, 1.1, 6.1, 1.1)
# axes = TRUE
# ... <- NULL
.xtplot.timeSeries <-
function(
x, y = NULL, FinCenter = NULL,
plot.type = c("single", "multiple"),
format = "auto", at = c("pretty", "chic"),
panel = lines, yax.flip = FALSE,
mar.multi = c(0, 5.1, 0, if (yax.flip) 5.1 else 2.1),
oma.multi = c(7.75, 1.1, 6.1, 1.1), # oma.multi = c(6, 0, 5, 0),
axes = TRUE,
...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Plots timeSeries objects - Internal Function
# Details:
# A modified copy of R's internal 'plotts()' function,
# see 'plot.ts()'.
# FUNCTION:
dots <- list(...)
minor.ticks <- dots$minor.ticks %||% "auto"
type <- dots$type %||% "l"
col <- dots[["col"]] %||% { 1:NCOL(x) }
pch <- dots$pch %||% 20
cex <- dots$cex %||% 1
lty <- dots$lty %||% 1
lwd <- dots[["lwd"]] %||% 1
grid <- dots$grid %||% TRUE
col.grid <- dots$col.grid %||% "darkgrey"
lwd.grid <- dots$lwd.grid %||% 1
frame.plot <- dots$frame.plot %||% TRUE
ann <- dots$ann %||% TRUE
cex.axis <- dots$cex.axis %||% 1
cex.lab <- dots$cex.lab %||% 1
cex.pch <- dots$cex.pch %||% 1
log <- dots$log %||% ""
equilogs <- dots$equilogs %||% TRUE
main <- dots$main %||% ""
xlab <- dots$xlab %||% ""
ylab <- dots$ylab %||% {
cn <- colnames(x)
if(length(cn) > 1 && (plot.type == "single" || plot.type == "s"))
"Values" else cn
}
xax <- dots[["xax"]] %||% FALSE
xaxs <- dots$xaxs %||% "r"
yaxs <- dots$yaxs %||% "r"
# Continue ...
if (minor.ticks == "auto") minor.ticks <- .periodicity2(x)$units
if (at[1] == "chic") minor.ticks <- TRUE
if (format != "auto") minor.ticks <- TRUE
# FinCenter - take care of it:
if (!is.null(FinCenter)) {
finCenter(x) <- FinCenter
if (!missing(y)) finCenter(y) <- FinCenter
if (is(at, "timeDate")) at@FinCenter <- FinCenter }
# Plot Type:
plot.type <- plot.type[1]
if(isUnivariate(x)) plot.type <- "single"
if(is.timeSeries(y)) plot.type <- "scatter"
# Axis Positions and Format:
AT <- at[1]
FORMAT <- format[1]
if (x@format == "counts") FORMAT <- "counts"
# Decorations:
# if (is.null(col)) col <- 1:ncol(x)
# if (col[1] == 0) col = 1 else col <- .colorwheelPalette(ncol(x))
# if (is.null(pch)) pch <- 20
# if (is.null(cex)) cex <- 1
# if (is.null(lty)) lty <- 1
# if (is.null(lwd)) lwd <- 2
if(is.null(type[1])) type <- "l"
if (length(type) == 1) type <- rep(type, times=NCOL(x))
if (length(col) == 1) col <- rep(col, times=NCOL(x))
if (length(pch) == 1) pch <- rep(pch, times=NCOL(x))
if (length(cex) == 1) cex <- rep(cex, times=NCOL(x))
if (length(lty) == 1) lty <- rep(lty, times=NCOL(x))
if (length(lwd) == 1) lwd <- rep(lwd, times=NCOL(x))
if (length(cex.pch) == 1) cex.pch <- rep(cex.pch, times=NCOL(x))
if (length(ylab) == 1) ylab <- rep(ylab, times=NCOL(x))
TIME <- time(x)
if (is.integer(TIME)) {
X <- TIME
AT <- "counts"
} else {
X <- as.POSIXct(TIME)
}
Y <- series(x)
if (AT == "pretty") {
at <- pretty(x)
}
if (AT == "chic" ) {
ep <- .axTicksByTime2(x, format=FORMAT)
at <- TIME[ep]
}
# SINGLE PLOT:
if (plot.type == "single" || plot.type == "s") {
# All curves in one Frame:
ylim <- dots$ylim %||% range(Y, na.rm=TRUE)
xlim <- dots$xlim # even if it is NULL
plot(X, Y[,1], type= "n", xlim = xlim, ylim = ylim,
axes = FALSE, main = "", xlab = "", ylab = "", log=log,
xaxs=xaxs, yaxs=yaxs)
for (i in 1:ncol(x)) {
lines(X, series(x)[, i], type = type[i],
col = col[i], lty = lty[i], lwd = lwd[i], pch = pch[i],
cex = cex.pch[i])
}
if (ann) {
title(main = main, xlab = xlab, ylab = ylab[1], cex.lab = cex.lab)
}
if (axes) {
# Y - Axis:
axis(2, cex.axis = cex.axis)
}
if (axes || xax) {
# X - Axis:
if (AT == "counts") {
axis(1, cex.axis = cex.axis)
} else if (AT == "pretty") {
at <- pretty(time(x))
if (FORMAT == "auto") format <- "%Y-%m-%d"
if (!is.null(minor.ticks)) {
minor.at <- timeSequence(time(x)[1], time(x)[nrow(x)],by = minor.ticks)
axis.POSIXct(1, at=minor.at, labels=FALSE, col='#BBBBBB',cex.axis = cex.axis)
}
axis.POSIXct(1, at = at, format = format, cex.axis = cex.axis)
} else if (AT == "chic" ) {
ep <- .axTicksByTime2(x, format=FORMAT)
if (minor.ticks) axis.POSIXct(1, at=TIME, labels=FALSE, col='#BBBBBB',cex.axis = cex.axis)
axis.POSIXct(1, at = TIME[ep], labels=names(ep),las=1, lwd=1, mgp=c(3, 1, 0), cex.axis = cex.axis)
} else {
if (minor.ticks) {
axis.POSIXct(1, at=TIME, labels=FALSE, col='#BBBBBB', cex.axis = cex.axis)
axis.POSIXct(1, at = at, format = format, cex.axis=cex.axis)
}
}
}
if (frame.plot) {
box("plot")
}
if(grid) {
if (!(AT %in% c("pretty","chic"))) at <- axTicks(1)
abline(v = at, lty = 3, col = col.grid, lwd = lwd.grid)
grid(NA, NULL, lty = 3, col = col.grid, lwd = lwd.grid, equilogs=equilogs)
}
return(invisible())
}
# MULTIPLE PLOT:
if (plot.type == "multiple" || plot.type == "m") {
nser <- ncol(x)
nc <- if (nser > 4) 2 else 1
nr <- ceiling(nser/nc)
oldpar <- par(mar = mar.multi, oma = oma.multi, mfcol = c(nr, nc))
on.exit(par(oldpar))
for (i in 1:nser) {
plot(X, Y[, i], axes = FALSE, ann = TRUE, type = "n",
xlab = "", ylab = "", # log = log,
col = col[i], pch = pch[i], lty = lty[i], lwd = lwd[i], cex = cex[i])
panel(X, Y[, i], type = type[i],
xlab = "", ylab = "", col = col[i], pch = pch[i], lty = lty[i],
lwd = lwd[i], cex = cex.pch[i])
y.side <- if (i%%2 || !yax.flip) 2 else 4
do.xax <- i%%nr == 0 || i == nser
if (frame.plot) {
box()
}
if (axes) {
axis(y.side, xpd = NA, cex.axis=cex.axis)
}
if (axes || xax) {
if (do.xax) {
if (AT == "counts") {
axis(1, cex.axis = 1.2 * cex.axis)
at <- axTicks(1)
} else if (AT == "pretty") {
at <- pretty(time(x))
if (FORMAT == "auto") format <- "%Y-%m-%d"
TIME <- time(x)
if (!is.null(minor.ticks)) {
minor.at <- timeSequence(
time(x)[1], time(x)[nrow(x)], by=minor.ticks)
axis.POSIXct(1, at=minor.at, labels=FALSE,
cex.axis = 1.2 * cex.axis, col='#BBBBBB') }
axis.POSIXct(1, at = at, format = format,
cex.axis = 1.2 * cex.axis)
} else if (AT == "chic" ) {
ep <- .axTicksByTime2(x, format=FORMAT)
at <- time(x)[ep]
format <- attr(ep, "format")
formatLabels <- names(ep)
TIME <- time(x)
if (minor.ticks)
axis.POSIXct(1, at=TIME, labels=FALSE, col='#BBBBBB',
cex.axis = 1.2 * cex.axis)
axis.POSIXct(1, at = TIME[ep], labels=names(ep),
las=1, lwd=1, mgp=c(3, 1, 0), cex.axis = cex.axis)
} else {
TIME <- time(x)
if (minor.ticks)
axis.POSIXct(1, at=TIME, labels=FALSE, col='#BBBBBB',
cex.axis = 1.2 * cex.axis)
axis.POSIXct(1, at = at, format = format,
cex.axis = 1.2 *cex.axis)
}
}
}
if (ann) {
mtext(text = ylab[i], side = y.side, line = 3, cex = cex.lab)
if (do.xax) mtext(xlab, side = 1, line = 3, cex = cex.lab)
if (i==1) {
cex.main <- if (is.null(dots$cex.lab)) par("cex.main") else cex.lab
mtext(main, side = 3, line = 3,
cex = cex.main,
font = par("font.main"),
col = par("col.main"))
}
}
if(grid) {
abline(v = at, lty = 3, col = col.grid, lwd = lwd.grid)
grid(NA, NULL, lty = 3, col = col.grid, lwd = lwd.grid, equilogs=equilogs)
}
} # end of nser loop
return(invisible())
}
# SCATTER PLOT:
if (!is.null(y)) {
stopifnot (isUnivariate(x))
stopifnot (isUnivariate(y))
plot(series(x), series(y), xlab="", ylab="", col=col, pch=pch, cex=cex)
return(invisible())
}
}
###############################################################################
# Test function for xts-plot-like axis positions and labels.
.xtsPlot <-
function(x, y=NULL,
type = "l",
ann = TRUE,
axes = TRUE,
major.ticks = 'auto',
minor.ticks = TRUE,
major.format = TRUE,
grid = TRUE,
box = TRUE,
...)
{
# A function written by Diethelm Wuertz
# Descroption:
# A simple example to test the xts functions to generate
# nice axis positions and Lebels
# Example:
# x <- 100 * cumulated(LPP2005REC[, 2]); xtsPlot(x)
# Settings:
# time.scale <- periodicity2(x)$scale
ep <- .axTicksByTime2(x, major.ticks, format.labels=major.format)
# PLOT COORDS:
xycoords <- xy.coords(time(x), x[, 1])
# RAW PLOT:
plot(xycoords$x, xycoords$y, type=type, axes=FALSE, ann=FALSE, ...)
# ADD GRID:
if (grid) {
abline(v=xycoords$x[ep], col='grey', lty=3)
grid(NA, NULL)
}
# ADD AXIS:
if(axes) {
if(minor.ticks)
axis(1, at=xycoords$x, labels=FALSE, col='#BBBBBB')
axis(1, at=xycoords$x[ep], labels=names(ep), las=1, lwd=1, mgp=c(3,2,0))
axis(2)
}
# ADD BOX:
box()
}
# -----------------------------------------------------------------------------
# Borrowed from ...
# Package: xts
# Title: eXtensible Time Series
# Version: 0.9-7
# Date: 2013-06-26
# Author: Jeffrey A. Ryan, Joshua M. Ulrich
# Maintainer: Jeffrey A. Ryan <jeff.a.ryan@gmail.com>
# License: GPL (>= 2)
# URL: http://r-forge.r-project.org/projects/xts/
# Packaged: 2014-01-02 18:00:13 UTC; ripley
# NeedsCompilation: yes
# Repository: CRAN
# Date/Publication: 2014-01-02 19:18:28
.axTicksByTime2 <-
function(
x, ticks.on='auto', k=1,
labels=TRUE, format.labels=TRUE, ends=TRUE, gt = 2, lt = 30,
format = "auto")
{
# A modified function borrowed from the xts-package
# Arguments:
# x - a 'timeSerie' Object
# Example:
# x <- 100 * cumulated(LPP2005REC[, 2]); .axTicksByTime2(x)
tick.opts <- c(
"years", "months", "weeks", "days", "hours", "minutes", "seconds")
tick.k.opts <- c(
10, 5, 2, 1, 6, 1, 1, 1, 4, 2, 1, 30, 15, 1, 1)
if (ticks.on %in% tick.opts) {
cl <- ticks.on[1]
ck <- k
} else {
tick.opts <- paste(rep(tick.opts, c(4, 2, 1, 1, 3, 3, 1)), tick.k.opts)
is <- structure(rep(0,length(tick.opts)), .Names = tick.opts)
for(i in 1:length(tick.opts)) {
y <- strsplit(tick.opts[i], ' ')[[1]]
ep <- .endpoints2(x, y[1], as.numeric(y[2]))
is[i] <- length(ep) -1
if(is[i] > lt)
break
}
nms <- rev(names(is)[which(is > gt & is < lt)])[1]
cl <- strsplit(nms, " ")[[1]][1]
ck <- as.numeric(strsplit(nms, " ")[[1]][2])
}
ep <- if (is.null(cl)) NULL else .endpoints2(x, cl, ck)
if(ends)
ep <- ep + c(rep(1,length(ep)-1),0)
if (labels) {
if(is.logical(format.labels) || is.character(format.labels)) {
# format by level of time detail, and platform
unix <- ifelse(.Platform$OS.type=="unix", TRUE, FALSE)
time.scale <- .periodicity2(x)$scale
fmt <- ifelse(unix, '%n%b%n%Y', '%b %Y')
if (time.scale == "weekly" | time.scale == "daily")
fmt <- ifelse(unix, '%b %d%n%Y', '%b %d %Y')
if (time.scale == "minute" | time.scale == "hourly")
fmt <- ifelse(unix, '%b %d%n%H:%M', '%b %d %H:%M')
if (time.scale == "seconds")
fmt <- ifelse(unix, '%b %d%n%H:%M:%S', '%b %d %H:%M:%S')
if(is.character(format.labels)) fmt <- format.labels
if (format != "auto") fmt <- format
names(ep) <- format(time(x)[ep], fmt)
} else {
names(ep) <- as.character(time(x)[ep])
}
}
attr(ep, "format") <- fmt
# Return Value:
ep
}
################################################################################
.endpoints2 <-
function (x, on = c("months", "years", "quarters", "weeks", "days",
"hours", "minutes", "seconds"), k = 1)
{
# A modified function borrowed from the xts-package
# Arguments:
# x - a 'timeDate' object
# Example:
# x <- 100 * cumulated(LPP2005REC[, 2]); .endpoints2(x)
stopifnot(is(x, "timeSeries"))
x <- time(x)
on <- match.arg(on)
posix <- as.POSIXct(x, origin="1970-01-01")
.posix <- unclass(posix)
if (on == "years") {
ans <- as.integer(which(diff(as.POSIXlt(posix)$year%/%k + 1) != 0))
}
else if (on == "quarters") {
ans <- as.integer(which(diff((as.POSIXlt(posix)$mon%/%3) + 1) != 0))
}
else if (on == "months") {
ans <- as.integer(which(diff(as.POSIXlt(posix)$mon%/%k + 1) != 0))
}
else if (on == "weeks") {
ans <- as.integer(
which(diff((.posix + (3L * 86400L))%/%604800L%/%k + 1) != 0))
}
else if (on == "days") {
ans <- as.integer(which(diff(.posix%/%86400L%/%k + 1) != 0))
}
else if (on == "hours") {
ans <- as.integer(which(diff(.posix%/%3600L%/%k + 1) != 0))
}
else if (on == "minutes" || on == "mins") {
ans <- as.integer(which(diff(.posix%/%60L%/%k + 1) != 0))
}
else if (on == "seconds" || on == "secs") {
ans <- as.integer(which(diff(.posix%/%k + 1) != 0))
}
ans <- c(0, ans, NROW(x))
# Return Value:
ans
}
###############################################################################
.periodicity2 <-
function (x)
{
# A modified function borrowed from the xts-package
# Arguments:
# x - a 'timeDate' object
# Example:
# x <- 100 * cumulated(LPP2005REC[, 2]); .periodicity2(x)
# FUNCTION:
# Check Argument:
stopifnot(is(x, "timeSeries"))
x <- time(x)
p <- median(diff(as.integer(as.POSIXct(x, origin="1970-01-01"))))
if (is.na(p)) stop("cannot calculate periodicity of 1 observation")
units <- "days"
scale <- "yearly"
label <- "year"
if (p < 60) {
units <- "secs"
scale <- "seconds"
label <- "second"
} else if (p < 3600) {
units <- "mins"
scale <- "minute"
label <- "minute"
p <- p/60L
} else if (p < 86400) {
units <- "hours"
scale <- "hourly"
label <- "hour"
} else if (p == 86400) {
units <- "days"
scale <- "daily"
label <- "day"
} else if (p <= 604800) {
units <- "weeks"
scale <- "weekly"
label <- "week"
} else if (p <= 2678400) {
units <- "months"
scale <- "monthly"
label <- "month"
} else if (p <= 7948800) {
units <- "quarter"
scale <- "quarterly"
label <- "quarter"
}
# Return Value:
list(
difftime = structure(p, units = units, class = "difftime"),
frequency = p, start = start(x), end = end(x), units = units,
scale = scale, label = label)
}
###############################################################################
.colorwheelPalette <-
function(n)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Color Wheel:
orig <- c(
"#FFF200", "#FBAA19", "#F26522", "#EF4823",
"#ED1D24", "#A9285F", "#662D91", "#4D2F91",
"#2E3092", "#00707E", "#00A650", "#8CC63F")
orig <- orig[-1]
# Splice Wheel
if (n == 11) return(orig)
rgb.tim <- t(col2rgb(orig))
temp <- matrix(NA, ncol = 3, nrow = n)
x <- seq(0, 1, , 11)
xg <- seq(0, 1, , n)
for (k in 1:3) {
hold <- spline(x, rgb.tim[, k], n = n)$y
hold[hold < 0] <- 0
hold[hold > 255] <- 255
temp[, k] <- round(hold)
}
ans <- rgb(temp[, 1], temp[, 2], temp[, 3], maxColorValue = 255)
# Return Value:
ans
}
###############################################################################
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.