I used the function plot.ACF (package nlme) to do a graph of the autocorrelations for model residuals.The problem is that the autocorrelations in the graph are very hard to read. How can I modify the limit of the y axis in the function plot.ACF ?
Here is my graph:
The nlme:::plot.ACF function has a hard-coded ylim assignment, so you have to modify the function slightly (the comment lines below are the only places I made changes).
my_acf_plot <- function (x, alpha = 0, xlab = "Lag", ylab = "Autocorrelation",
grid = FALSE,
ylim = NULL, ## add ylim
...)
{
require("lattice") ## for xyplot, panel.* function
## (unnecessary originally because the package imports
## the required functions)
object <- x
if (is.null(ylim)) ylim <- range(object$ACF) ## set ylim if unset
if (alpha) {
assign("stdv", qnorm(1 - alpha/2)/sqrt(attr(object, "n.used")))
stMax <- max(stdv)
ylim <- c(min(c(-stMax, ylim[1])), max(c(ylim[2], stMax)))
}
assign("alpha", as.logical(alpha))
assign("grid", grid)
xyplot(ACF ~ lag, object, ylim = ylim, panel = function(x,
y, ...) {
x <- as.numeric(x)
y <- as.numeric(y)
if (grid)
panel.grid()
panel.xyplot(x, y, type = "h")
panel.abline(0, 0)
if (alpha) {
llines(x, stdv, lty = 2)
llines(x, -stdv, lty = 2)
}
}, xlab = xlab, ylab = ylab, ...)
}
Example:
library(nlme)
set.seed(101)
d <- data.frame(y=rnorm(50),x=1:50)
my_acf_plot(ACF(gls(y~x,data=d)),ylim=c(-0.3,0.5))
Related
I am familiar with polygon and ggplot2, but I like working with basic plot.
I want to fill in the curve called by the command:
curve(dnorm(x, 0.5, 0.22), xlim=c(-0.5, 1.5))
When in the past I have used polygon I defined the end points based on prior calculations of x along the lines of x <- seq(-0.5, 0.5, len = 100), for example, and y <- dnorm(x, 0.5, 0.22). Next, the limits are defined within polygon, the color selected, et voilà... in less than a fortnight, there is color...
OK, not exactly fast, but in this particular case, I haven't even explicitly defined x and y outside curve, which makes the whole process even more cumbersome. It's almost like starting afresh.
Is there any way of doing it fast, perhaps with something like fill, col or other plotting parameters within curve?
You can actually modify the curve function relatively easily. The only changes I've made are:
1) Add a fill parameter defaulting to "red"
2) Add a polygon plot at the end of the function (marked with a comment)
Here's the function in action. See below for the function code.
my_curve(dnorm(x, 0.5, 0.22), xlim=c(-0.5, 1.5), fill="green")
I'm not sure that this is any more expedient that just doing:
x=seq(-0.5,1.5,0.01)
plot(x, dnorm(x,0.5,0.22), xlim=c(-0.5,1.5), type="l")
polygon(x, dnorm(x,0.5,0.22), col="green")
But if you're going to be using it a lot, you can source my_curve in your scripts or create a package with the new version of curve that masks the base version. You could also make the fill optional and perhaps add a feature that allows partial filling.
If you're not wild about the ggplot2 defaults, you can also get rid of them, while still keeping the benefits of ggplot's grammar:
library(ggplot2)
df = data.frame(x=seq(-0.5,1.5,0.01), y=dnorm(x,0.5,0.22))
ggplot(df, aes(x,y)) +
geom_area(colour="black", fill="red") +
theme_bw() +
theme(panel.grid=element_blank())
Here's the modified curve function:
my_curve = function (expr, from = NULL, to = NULL, n = 101, add = FALSE,
type = "l", xname = "x", xlab = xname, ylab = NULL, log = NULL,
xlim = NULL, fill="red", ...)
{
sexpr <- substitute(expr)
if (is.name(sexpr)) {
expr <- call(as.character(sexpr), as.name(xname))
}
else {
if (!((is.call(sexpr) || is.expression(sexpr)) && xname %in%
all.vars(sexpr)))
stop(gettextf("'expr' must be a function, or a call or an expression containing '%s'",
xname), domain = NA)
expr <- sexpr
}
if (dev.cur() == 1L && !identical(add, FALSE)) {
warning("'add' will be ignored as there is no existing plot")
add <- FALSE
}
addF <- identical(add, FALSE)
if (is.null(ylab))
ylab <- deparse(expr)
if (is.null(from) || is.null(to)) {
xl <- if (!is.null(xlim))
xlim
else if (!addF) {
pu <- par("usr")[1L:2L]
if (par("xaxs") == "r")
pu <- extendrange(pu, f = -1/27)
if (par("xlog"))
10^pu
else pu
}
else c(0, 1)
if (is.null(from))
from <- xl[1L]
if (is.null(to))
to <- xl[2L]
}
lg <- if (length(log))
log
else if (!addF && par("xlog"))
"x"
else ""
if (length(lg) == 0)
lg <- ""
if (grepl("x", lg, fixed = TRUE)) {
if (from <= 0 || to <= 0)
stop("'from' and 'to' must be > 0 with log=\"x\"")
x <- exp(seq.int(log(from), log(to), length.out = n))
}
else x <- seq.int(from, to, length.out = n)
ll <- list(x = x)
names(ll) <- xname
y <- eval(expr, envir = ll, enclos = parent.frame())
if (length(y) != length(x))
stop("'expr' did not evaluate to an object of length 'n'")
if (isTRUE(add))
lines(x = x, y = y, type = type, ...)
else plot(x = x, y = y, type = type, xlab = xlab, ylab = ylab,
xlim = xlim, log = lg, ...)
polygon(x,y, col=fill) # Add filled area under curve
invisible(list(x = x, y = y))
}
I am currently busy with a Vector Autoregressive Analysis in R, using the vars package. I was wondering if the following things are possible:
1) the previous solution for a better fit on the page worked properly, but now with more variables, we have more plots and the layout is screwed again. I already played with some of the win.graph() parameters, but nothing gives me a proper readable solution.
2) The plot(irf(...) function of the vars package gives a one-graph per page output. I was wondering if this is also possible for the plot(fevd() function by adding some extra (unkown to me) parameters options
3) Also, for readability, I would like to color the graphs, plot(fevd() gives an all-kinds-of-gray output, Is it possible to change those colors?
Thank you in advance
Olivier
You will have to modify the plot function for fevd to do what you want. Here's a modified plot.varfevd function that removes all calls to par(). This allows to use layout properly. The lines that have been removed have been commented out (#). I also removed the parameter that asked for confirmation in "single" plots.
plot.varfevd <-function (x, plot.type = c("multiple", "single"), names = NULL,
main = NULL, col = NULL, ylim = NULL, ylab = NULL, xlab = NULL,
legend = NULL, names.arg = NULL, nc, mar = par("mar"), oma = par("oma"),
addbars = 1, ...)
{
K <- length(x)
ynames <- names(x)
plot.type <- match.arg(plot.type)
if (is.null(names)) {
names <- ynames
}
else {
names <- as.character(names)
if (!(all(names %in% ynames))) {
warning("\nInvalid variable name(s) supplied, using first variable.\n")
names <- ynames[1]
}
}
nv <- length(names)
# op <- par(no.readonly = TRUE)
ifelse(is.null(main), main <- paste("FEVD for", names), main <- rep(main,
nv)[1:nv])
ifelse(is.null(col), col <- gray.colors(K), col <- rep(col,
K)[1:K])
ifelse(is.null(ylab), ylab <- rep("Percentage", nv), ylab <- rep(ylab,
nv)[1:nv])
ifelse(is.null(xlab), xlab <- rep("Horizon", nv), xlab <- rep(xlab,
nv)[1:nv])
ifelse(is.null(ylim), ylim <- c(0, 1), ylim <- ylim)
ifelse(is.null(legend), legend <- ynames, legend <- legend)
if (is.null(names.arg))
names.arg <- c(paste(1:nrow(x[[1]])), rep(NA, addbars))
plotfevd <- function(x, main, col, ylab, xlab, names.arg,
ylim, ...) {
addbars <- as.integer(addbars)
if (addbars > 0) {
hmat <- matrix(0, nrow = K, ncol = addbars)
xvalue <- cbind(t(x), hmat)
barplot(xvalue, main = main, col = col, ylab = ylab,
xlab = xlab, names.arg = names.arg, ylim = ylim,
legend.text = legend, ...)
abline(h = 0)
}
else {
xvalue <- t(x)
barplot(xvalue, main = main, col = col, ylab = ylab,
xlab = xlab, names.arg = names.arg, ylim = ylim,
...)
abline(h = 0)
}
}
if (plot.type == "single") {
# par(mar = mar, oma = oma)
# if (nv > 1)
# par(ask = TRUE)
for (i in 1:nv) {
plotfevd(x = x[[names[i]]], main = main[i], col = col,
ylab = ylab[i], xlab = xlab[i], names.arg = names.arg,
ylim = ylim, ...)
}
}
else if (plot.type == "multiple") {
if (missing(nc)) {
nc <- ifelse(nv > 4, 2, 1)
}
nr <- ceiling(nv/nc)
par(mfcol = c(nr, nc), mar = mar, oma = oma)
for (i in 1:nv) {
plotfevd(x = x[[names[i]]], main = main[i], col = col,
ylab = ylab[i], xlab = xlab[i], names.arg = names.arg,
ylim = ylim, ...)
}
}
# on.exit(par(op))
}
Then, you will need short variable names. Pick acronyms if needed.
library(vars)
data(Canada)
colnames(Canada) <-c("name1","name2","name3","name4")
var <- VAR(Canada , p=4 , type = "both")
Using a wide plot window (using win.graph) and using layout (to get the placement of your eight plots), you can get all charts displayed properly. I also changed the colors of the plots as requested. Finally, we are now using single plots as there are no calls to par() which do not sit well with layout().
win.graph(width=15,height=8)
layout(matrix(1:8,ncol=2))
plot.varfevd(fevd(var, n.ahead = 10 ),plot.type = "single", col=1:4)
plot.varfevd(fevd(var, n.ahead = 10 ),plot.type = "single", col=1:4)
I'm trying to plot the below dataset using plot function. Im unable to plot both the graphs in same plot.
Using the dataset I tried to plot the graph.
m_bs = conpl$new(sample_data1$V1)
m_eq = conpl$new(sample_data2$V1)
est = estimate_xmin(m_bs, xmax=5e+5)
est_eq = estimate_xmin(m_eq, xmax=Inf)
m_bs$setXmin(est_bs)
m_eq$setXmin(est_eq)
plot(m_bs)
lines(m_bs)
d = plot(m_eq, draw =FALSE)
points(d$x, d$y, col=2)
lines(m_eq,col=2,lwd=2)
I got the below graph, it only shows one graph. Sorry for posting the question again I didnt get proper answer earlier post.
I looked up the source code of the plot function used by poweRlaw and modified it:
lines_ <- function (x, y, ...)
{
.local <- function (x, cut = FALSE, draw = TRUE, ...)
{
xmin = x$getXmin()
cut_off = cut * xmin
x_values = x$dat
if (!cut)
x$setXmin(min(x_values))
y = dist_data_cdf(x, lower_tail = FALSE, xmax = max(x_values) + 1)
cut_off_seq = (x_values >= cut_off)
x_axs = x_values[cut_off_seq]
if (is(x, "discrete_distribution"))
x_axs = unique(x_axs)
x$setXmin(xmin)
x = x_axs
if (draw)
lines(x, y, ...)
invisible(data.frame(x = x, y = y))
}
.local(x, ...)
}
#----------------------------------------------------------
points_ <- function (x, y, ...)
{
.local <- function (x, cut = FALSE, draw = TRUE, ...)
{
xmin = x$getXmin()
cut_off = cut * xmin
x_values = x$dat
if (!cut)
x$setXmin(min(x_values))
y = dist_data_cdf(x, lower_tail = FALSE, xmax = max(x_values) + 1)
cut_off_seq = (x_values >= cut_off)
x_axs = x_values[cut_off_seq]
if (is(x, "discrete_distribution"))
x_axs = unique(x_axs)
x$setXmin(xmin)
x = x_axs
if (draw)
points(x, y, ...)
invisible(data.frame(x = x, y = y))
}
.local(x, ...)
}
The functions lines_ and points_
draw the same graph as the plot function of the poweRlaw package, but
behave like the standard lines and points functions in that they don't destroy the current graph.
First m_bs and 'm_eq' separately:
> plot(m_bs, lwd=9, col="black")
> lines_(m_bs, lwd=5, col="green")
> plot(m_eq, lwd=9, col="black")
> lines_(m_eq, lwd=5, col="blue")
The x-ranges of these to graphs do not overlap. Hence xlim has to be chosen appropriately to show both graphs in the same picture.
> plot( m_eq, lwd=8, col="black",
+ xlim=c(min(m_bs$dat,m_eq$dat),max(m_bs$dat,m_eq$dat)))
> lines_(m_eq, lwd=5, col="blue")
> points_(m_bs,lwd=8,col="black")
> lines_(m_bs, lwd=5, col="green")
>
Let's say I'm doing a linear model with y ~ x. I get the residuals plot for example with
plot(lm(y ~ x, data.frame(x=c(1,2,3), y=c(4,6,9))), 1)
How can I set the ylim for this plot? (Supplying e.g. ylim=c(-1,1) to this function doesn't work).
ylim is hard-coded into the function stats:::plot.lm (i.e., the s3 plot method for objects of class "lm"). This function is not exported from the stats package. To get around this, you could copy the function and modify it:
plotlm <- stats:::plot.lm
You can edit it using fix("plotlm"). Add a ylim formal argument to the function definition and then find the relevant part of the code. You should change:
if (show[1L]) {
ylim <- range(r, na.rm = TRUE)
if (id.n > 0)
ylim <- extendrange(r = ylim, f = 0.08)
dev.hold()
plot(yh, r, xlab = l.fit, ylab = "Residuals", main = main,
ylim = ylim, type = "n", ...)
# ...
to:
if (show[1L]) {
if(missing(ylim)) {
ylim <- range(r, na.rm = TRUE)
if (id.n > 0)
ylim <- extendrange(r = ylim, f = 0.08)
}
dev.hold()
plot(yh, r, xlab = l.fit, ylab = "Residuals", main = main,
ylim = ylim, type = "n", ...)
# ...
Then you can call this new function:
plotlm(lm(y ~ x, data.frame(x=c(1,2,3), y=c(4,6,9))), 1, ylim = c(-1,1))
And obtain the desired result:
I know I can use panel.xyarea from latticeExtra to fill the area in the plot with any colour. Without defining a type argument in xyplot, such filling will follow the route of default type="p":
library(lattice)
library(latticeExtra)
data <- data.frame(time=1:24,value=rnorm(24))
xyplot(value~time, data,
panel=function(x,y,...){
panel.xyarea(x,y,...)
panel.xyplot(x,y,...)})
This plots both panel.xyarea and the points coming from default type="p" in panel.xyplot. Now the problem arise when I want to change the type of plotting line, for example making it step function type="S":
xyplot(value~time, data, type="S",
panel=function(x,y,...){
panel.xyarea(x,y,...)
panel.xyplot(x,y,...)}
As you see on the example above, panel.xyarea doesn't fill the area underneath the new step function, but instead it plots both areas overlapping. It doesn't change anything if I move type="S" to the panel.xyarea - in fact it doesn't register type argument it at all and plots as it wouldn't be there.
Is there a way I can bypass this and have panel.xyarea fill my plots whatever type I define - be it step function (type="S"), loess (type="smooth") or regression (type="r")? Or maybe there is something better than panel.xyarea to use in such context?
For each value of type, you'll need to construct a custom panel function. Fortunately, if you model the functions closely on existing lattice code (starting out by having a look at panel.xyplot), that shouldn't be too hard. For example, the two custom panel functions below include many lines of code but only a couple of lines (marked with comments) that I had to write.
Once you've defined the panel functions (copying them in from the code blocks following the figure), use them like this:
library(lattice)
library(latticeExtra)
library(gridExtra)
set.seed(100)
data <- data.frame(time=1:24,value=rnorm(24))
## Filled version of xyplot(..., type="S")
a <- xyplot(value~time, data, panel=panel.filled_S)
## Filled version of xyplot(..., type="smooth")
b <- xyplot(value~time, data, panel=panel.filled_smooth)
grid.arrange(a, b, ncol = 2)
For a filled version of type="S":
## Modeled on code in panel.xyplot, which is called when type=S"
panel.filled_S <-
function(x,y, ...) {
horizontal <- FALSE ## Edited (may not want to hardcode)
ord <- if (horizontal)
sort.list(y)
else sort.list(x)
n <- length(x)
xx <- numeric(2 * n - 1)
yy <- numeric(2 * n - 1)
xx[2 * 1:n - 1] <- x[ord]
yy[2 * 1:n - 1] <- y[ord]
xx[2 * 1:(n - 1)] <- x[ord][-n]
yy[2 * 1:(n - 1)] <- y[ord][-1]
panel.xyarea(x = xx, y = yy, ...) ## Edited
panel.lines(x = xx, y = yy, ...) ## Edited
}
xyplot(value~time, data, panel=panel.filled_S, type="o")
For a filled version of type="smooth":
## Modeled on code in panel.loess, called by panel.xyplot when type="smooth"
panel.filled_smooth <-
function (x, y, span = 2/3, degree = 1, family = c("symmetric",
"gaussian"), evaluation = 50, lwd = plot.line$lwd, lty = plot.line$lty,
col, col.line = plot.line$col, type, horizontal = FALSE,
..., identifier = "loess")
{
x <- as.numeric(x)
y <- as.numeric(y)
ok <- is.finite(x) & is.finite(y)
if (sum(ok) < 1)
return()
if (!missing(col)) {
if (missing(col.line))
col.line <- col
}
plot.line <- trellis.par.get("plot.line")
if (horizontal) {
smooth <- loess.smooth(y[ok], x[ok], span = span, family = family,
degree = degree, evaluation = evaluation)
panel.lines(x = smooth$y, y = smooth$x, col = col.line,
lty = lty, lwd = lwd, ..., identifier = identifier)
panel.xyarea(smooth$y, smooth$x, ...) ## Edited
}
else {
smooth <- loess.smooth(x[ok], y[ok], span = span, family = family,
degree = degree, evaluation = evaluation)
panel.lines(x = smooth$x, y = smooth$y, col = col.line,
lty = lty, lwd = lwd, ..., identifier = identifier)
panel.xyarea(smooth$x, smooth$y, ...) ## Edited
}
smooth
}