Nothing
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received A copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
################################################################################
# FUNCTION: INTERNAL USED PLOT FUNCTIONS:
# .residualsPlot Returns a residual series plot
# .acfPlot Returns a autocorrelation function plot
# .pacfPlot Returns a partial ACF plot
# .mrlPlot Returns a mean residual life plot
# FUNCTION: INTERNAL USED BIVARIATE PLOT FUNCTIONS:
# .responsesPlot Returns a response series plot
# .firePlot Returns a fitted values vs.residuals plot
# FUNCTION: INTERNAL THREE-DIMENSIONAL PLOT UTILITIES:
# .circlesPlot Returns a circles plot indexing 3rd variable
# .perspPlot Returns a perspective plot in 2 dimensions
# .contourPlot Returns a contour plot in 2 dimensions
# .histStack Returns a stacked histogram plot
################################################################################
.residualsPlot <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Returns time series graph of residuals
# Arguments:
# x - an univariate time series of residuals
# FUNCTION:
# Get Data:
x = as.vector(x)
# Plot:
plot(x, type = "l", ylab = "Residuals",
main = "Residual Series", col = "steelblue", ...)
rug(x, ticksize = 0.01, side = 4)
grid()
abline(h = 0, col = "grey")
# Return Value:
invisible()
}
# ------------------------------------------------------------------------------
.acfPlot <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Convert Type:
x = as.vector(x)
# ACF:
acf(x, ...)
# Return Value:
invisible()
}
# ------------------------------------------------------------------------------
.pacfPlot <-
function(x, ...)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Convert Type:
x = as.vector(x)
# ACF:
pacf(x, ...)
# Return Value:
invisible()
}
# ------------------------------------------------------------------------------
.mrlPlot <-
function(x, ci = 0.95, umin = mean(x), umax = max(x), nint = 100,
doplot = TRUE, plottype = c("autoscale", ""), labels = TRUE, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Create a mean residual life plot with
# confidence intervals.
# References:
# A function originally written by S. Coles
# FUNCTION:
# Convert Type:
x = as.vector(x)
# Settings:
plottype = plottype[1]
# Convert x to a vector, if the input is a data.frame.
if (is.data.frame(x)) x = x[,1]
sx = xu = xl = rep(NA, nint)
u = seq(umin, umax, length = nint)
for (i in 1:nint) {
x = x[x >= u[i]]
sx[i] = mean(x - u[i])
sdev = sqrt(var(x))
n = length(x)
xu[i] = sx[i] + (qnorm((1 + ci)/2) * sdev) / sqrt(n)
xl[i] = sx[i] - (qnorm((1 + ci)/2) * sdev) / sqrt(n)
}
# Plot:
if (doplot) {
if (labels) {
xlab = "Threshold: u"
ylab = "Mean Excess: e"
main = "Mean Residual Live Plot"
} else {
main = xlab = ylab = ""
}
if (plottype == "autoscale") {
ylim = c(min(xl[!is.na(xl)]), max(xu[!is.na(xu)]))
plot(u, sx, type = "o", pch = 19, col = "steelblue",
xlab = xlab, ylab = ylab, ylim = ylim, main = main, ...)
} else {
plot(u[!is.na(xl)], sx[!is.na(xl)], type = "o",
pch = 19, col = "steelblue",
xlab = xlab, ylab = ylab, main = main, ...)
}
lines(u[!is.na(xl)], xl[!is.na(xl)], col = "brown")
lines(u[!is.na(xu)], xu[!is.na(xu)], col = "brown")
if (labels) {
grid()
text = paste("ci =", as.character(round(ci, 3)))
mtext(text, side = 4, adj = 0, cex = 0.7)
}
}
# Result
result = data.frame(threshold = u, mrl = sx)
# Return Value:
if (doplot) return(invisible(result)) else return(result)
}
################################################################################
.responsesPlot <-
function(x, y = NULL, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Returns time series graph of responses and fitted values
# Arguments:
# x - an univariate time series of responses
# y - an univariate time series of fitted values
# FUNCTION:
# Get Data:
x = as.vector(x)
y = as.vector(y)
# Responses Plot:
plot(x, type = "l", ylab = "Responses",
main = "Responses & Fitted Values", col = "steelblue", ...)
rug(x, ticksize = 0.01, side = 4)
grid()
abline(h = 0, col = "grey")
# Add fitted values:
if (!is.null(y)) points(y, pch = 19, col = "red")
# Return Value:
invisible()
}
# ------------------------------------------------------------------------------
.firePlot <-
function(x, y, method = c("scatter", "hist"), ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Returns fitted values vs. residuals plots
# Arguments:
# x - univariate time series (residuals)
# y - univariate time series (fitted)
# FUNCTION:
# Check Arguments:
method = match.arg(method)
# Get Data:
x = as.vector(x)
y = as.vector(y)
if (method == "scatter") {
# Scatter Plot:
plot(x, y,
xlab = "Fitted Values", ylab = "Residuals",
main = "Residuals vs Fitted",
pch = 19, col = "steelblue")
panel.smooth(x, y)
abline(h = 0, lty = 3, col = "grey")
rug(x, ticksize = 0.01, side = 3)
rug(y, ticksize = 0.01, side = 4)
} else if (method == "hist") {
# Histogram Plot:
# Save default, for resetting ...
def.par = par(no.readonly = TRUE)
# Layout:
nf = layout(matrix(c(2, 0, 1, 3), 2, 2, byrow = TRUE), c(3, 1),
c(1, 3), TRUE)
# Scatterplot:
par(mar = c(3 ,3, 1, 1))
plot(x, y, xlim = range(x), ylim = range(y),
xlab = "", ylab = "", pch = 19, col = "steelblue")
panel.smooth(x, y)
abline(h = 0, lty = 3, col = "grey")
rug(x, side = 3)
rug(y, side = 4)
# Histogram:
xhist = hist(x, nclass = 15, plot = FALSE)
yhist = hist(y, nclass = 15, plot = FALSE)
top = max(c(xhist$counts, yhist$counts))
# X-Side:
par(mar = c(0, 3, 1, 1))
Main = "\n Fitted"
barplot(xhist$counts, axes = FALSE, ylim = c(0, top),
space = 0, col = "steelblue", border = "white",
main = Main)
abline(h = 0, lwd = 2, col = "grey")
# Y-Side:
par(mar = c(3, 0, 1, 1))
barplot(yhist$counts, axes = FALSE, xlim = c(0, top),
space = 0, col = "steelblue", , border = "white",
horiz = TRUE, main = "Residuals")
abline(v = 0, lwd = 2, col = "grey")
# Reset:
par(def.par)
}
# Return Value:
invisible()
}
################################################################################
.circlesPlot <-
function(x, y = NULL, z = NULL, scale = 1, points = TRUE,
labels = TRUE, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Creates a scatterplot with circle size as third variable
# Example:
# circlesPlot(x=rnorm(50), y=rnorm(50), z=rnorm(50))
# circlesPlot(x=rnorm(50), y=rnorm(50), z=rnorm(50), labels= FALSE)
# FUNCTION:
# Transfor Input:
if (is.list(x)) x = matrix(unlist(x), ncol = 3)
if (is.data.frame(x)) x = as.matrix.data.frame(x)
if (is.matrix(x)) {
z = x[, 3]
y = x[, 2]
x = x[, 1]
}
nX = length(x)
nY = length(y)
# nZ = length(z)
stopifnot(nX == nY)
# stopifnot(nX == nZ || nX*nY == nZ)
# Create Circle Plot:
if (labels) {
plot(x, y, type = "n")
} else {
plot(x, y, xlab = "", ylab = "", type = "n")
}
symbols(x, y, add = TRUE, circles = abs(z)^scale, inches = 0.25,
fg = "black", bg = "steelblue", ...)
X = x[z < 0]
Y = y[z < 0]
Z = z[z < 0]
symbols(X, Y, add = TRUE, circles = abs(Z)^scale, inches = 0.25,
fg = "black", bg = "orange", ...)
if (points) points(x, y, pch = 19)
grid()
# Return Value:
invisible(NULL)
}
# ------------------------------------------------------------------------------
.perspPlot <-
function(x, y, z, theta = -40, phi = 30, col = "steelblue", ps = 9, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Returns a perspecvtive plot
# Notes:
# A synonyme call for function 'persp'
# FUNCTION:
# Perspective Plot:
if (inherits(version, "Sversion")) {
# we assume SPlus:
ans = persp(x = x, y = y, z = z, ...)
} else {
# R:
par(ps = ps)
if (!exists("ticktype")) ticktype = "detailed"
if (!exists("expand")) expand = 0.6
if (!exists("r")) r = 500
ans = persp(x = x, y = y, z = z, theta = theta, phi = phi,
col = col, ticktype = ticktype, expand = expand, ...)
}
# Return Value:
invisible(ans)
}
# ------------------------------------------------------------------------------
.contourPlot <-
function(x, y, z, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Returns a contour plot
# Notes:
# A synonyme call for function 'contour'
# FUNCTION:
# Contour Plot:
if (inherits(version, "Sversion")) {
# we assume SPlus:
ans = contour(x = x, y = y, z = z, ...)
} else {
# R:
ans = contour(x = x, y = y, z = z, ...)
}
# Return Value:
invisible(ans)
}
# ------------------------------------------------------------------------------
.histStack <-
function(x, y = NULL, space = 0, ylab = "frequency", ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Returns a stacked histogram Plot
# Example:
# .histStack(rnorm(1000, -1), rnorm(1000, 1))
# FUNCTION:
# Compute Histograms:
breaks = hist(c(x, y))$breaks
bars = rbind(
hist(x, breaks = breaks, plot = FALSE)$counts,
hist(y, breaks = breaks, plot = FALSE)$counts)
# Plot:
barplot(bars, space = space, ylab = ylab, ...)
at = seq(along = breaks) - 1
modulo = ceiling(length(at)/10)
sel = (at%%modulo == 0)
axis(side = 1, at = at[sel], labels = paste(breaks)[sel])
# Return Value:
invisible()
}
################################################################################
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.