I am using the rugarch package and I fitted a model. Now I want to look at the output and use the plot function. My problem is, that the 5th plot contains some subplots, which are plotted in one device, but I want to plot each in a single device. How can I do this? As an example I give you a code example, which uses the sp500ret data of the package:
The code:
library(rugarch)
data(sp500ret)
somemodel<-ugarchspec(variance.model = list(model = "sGARCH", garchOrder = c(2, 2)),
mean.model = list(armaOrder = c(1, 1), include.mean = TRUE),
distribution.model = "ged")
somefit<-ugarchfit(spec=somemodel,data=sp500ret)
rollingesti = ugarchroll(somemodel, sp500ret, n.start=500,
refit.every = 100, refit.window = 'moving', window.size = 500,
calculate.VaR = FALSE, keep.coef = TRUE)
plot(rollingesti,which=5)
the plot(rollingesti,which=5) plots several plots into one device, I want to isolate them.
So I want to have them as single plots and bigger, now, they are too small, since they are all put into one output.
Your example does not work (at least for me), i.e. it does not converge. However, this one works:
library(rugarch)
data(sp500ret)
spec <- ugarchspec(distribution.model = "std")
mod <- ugarchroll(spec, data = sp500ret[1:2000,], n.ahead = 1,
n.start = 1000, refit.every = 100, refit.window = "moving",
solver = "hybrid", fit.control = list(),
calculate.VaR = TRUE, VaR.alpha = c(0.01, 0.025, 0.05),
keep.coef = TRUE)
First, we find a method that is used in plot(mod, which = 5). It can be obtained by
getMethod("plot", c(x = "uGARCHroll", y = "missing"))
You are interested in the following lines
.intergarchrollPlot(x, choices = choices, plotFUN = paste(".plot.garchroll",
1:5, sep = "."), which = which, VaR.alpha = VaR.alpha,
density.support = density.support, ...)
where choices is "Fit Coefficients (with s.e. bands)". By inspecting rugarch:::.intergarchrollPlot we finally arrive to rugarch:::.plot.garchroll.5. These plots are not returned in any list or similar, hence I provide a bit modified version so that you could use them separately. Here I changed the first two and the last one line:
library(xts)
x <- mod
vmodel = x#model$spec#model$modeldesc$vmodel
if (!x#model$keep.coef)
stop("\n\nplot-->error: keep.coef set to FALSE in estimation\n")
coefs = x#model$coef
m = dim(coefs[[1]]$coef)[1]
N = length(coefs)
Z = matrix(NA, ncol = m, nrow = N)
Zup = matrix(NA, ncol = m, nrow = N)
Zdn = matrix(NA, ncol = m, nrow = N)
for (i in 1:m) {
Z[, i] = sapply(coefs, FUN = function(y) y$coef[i, 1])
Zup[, i] = Z[, i] + sapply(coefs, FUN = function(y) y$coef[i,
2])
Zdn[, i] = Z[, i] - sapply(coefs, FUN = function(y) y$coef[i,
2])
}
dt = sapply(coefs, FUN = function(y) as.character(y$index))
cnames = rownames(coefs[[1]]$coef)
np = rugarch:::.divisortable(m) # added rugarch:::
This is a function for each plot separately, i is a number of the graph, e.g. from 1 to 7 in this case:
plotFun <- function(i){
plot(xts(Z[, i], as.POSIXct(dt)), type = "l",
ylim = c(min(Zdn[, i]), max(Zup[, i])), ylab = "value", xlab = "", main = "",
minor.ticks = FALSE, ann = FALSE, auto.grid = FALSE)
lines(xts(Zdn[, i], as.POSIXct(dt)), col = 2)
lines(xts(Zup[, i], as.POSIXct(dt)), col = 2)
title(cnames[i], line = 0.4, cex = 0.9)
grid()
}
For example:
plotFun(1)
plotFun(2)
Related
I'm performing permutations and running apply to plot abline or lines from a linear model. But when using apply, I get "NULL" (but it draws the lines). How do I make the "NULL" go away and why is it doing that?
set.seed(12345678)
n = 100; beta0 = 2.5; beta1 = 0.8
x.lm = rnorm(n = n, mean = 10, sd = 1)
err = rnorm(n = n, mean = 0, sd = 1)
# Linear combination
y.lm = beta0 + beta1*x.lm + err
# Make a dataframe of the data
df.lm = data.frame(x = x.lm, y = y.lm)
par(mar = c(4,4,.5,.5))
# Colour
b.5 = scales::alpha("black",alpha = .5)
# PLot the data
plot(y~x, data = df.lm, pch = 19, col = b.5)
# Add permutations
permutate.df =replicate(n = 200, # nperm
expr = data.frame(y = sample(df.lm$y,size = nrow(df.lm), replace = FALSE), x = df.lm$x),
simplify = FALSE)
lm.out.perm = mapply(lm, permutate.df)
apply(lm.out.perm,2,function(x) abline(x,col = scales::alpha("orange",.5)))
abline return NULL, usually invisibly. Suggest writing the part from plot onwards like this. Alternately use invisible(Map(...)) in the last line. No packages are used.
plot(y~x, data = df.lm, pch = 19, col = adjustcolor("black", alpha = 0.5))
permuted_dfs <- with(df.lm, replicate(n = 200,
expr = data.frame(y = sample(y, replace = FALSE), x),
simplify = FALSE))
fms <- Map(lm, permuted_dfs) # fitted models
junk <- Map(abline, fms, col = adjustcolor("orange", alpha = 0.5))
or as a pipeline if you don't need the intermediate results.
plot(y~x, data = df.lm, pch = 19, col = adjustcolor("black", alpha = 0.5))
df.lm |>
with(replicate(n = 200,
expr = data.frame(y = sample(y, replace = FALSE), x),
simplify = FALSE)) |>
Map(f = lm) |>
Map(f = abline, col = adjustcolor("orange", alpha = 0.5)) |>
invisible()
I needed to include in the code below, a vertical line,
for example, in position x = 5 and that all points smaller than 5 have another color,
for example blue.
The values of a variable can be read from the x-axis, and the y-axis shows the order of the observations in the variable (from bottom to top). Isolated points as the far ends, and on either side in a plot, suggest potentional outliers
Thanks
library(dplyr)
library(lattice)
n = 1000
df <- tibble(
xx1 = runif(n, min = 3, max = 10),
xx2 = runif(n, min = 3, max = 10),
xx3 = runif(n, min = 3, max = 10)
)
MyVar <- c("xx1","xx2","xx3")
MydotplotBR <- function(DataSelected){
P <- dotplot(as.matrix(as.matrix(DataSelected)),
groups=FALSE,
strip = strip.custom(bg = 'white',
par.strip.text = list(cex = 1.2)),
scales = list(x = list(relation = "same",tck = 1,
draw = TRUE, at=seq(0,10,1)),x=list(at=seq),
y = list(relation = "free", draw = FALSE),
auto.key = list(x =1)),
col=10,
axes = FALSE,
cex = 0.4, pch = 5,
xlim=c(0,10),
xlab = list(label = "Variable Value", cex = 1.5),
ylab = list(label = "Order of data in the file", cex = 1.5))
print(P)
}
(tempoi <- Sys.time())
Vertemp <- MydotplotBR(df[,MyVar])
(tempof <- Sys.time()-tempoi)
I find it weird that you want a color dependent only on the x-axis when values are also used on the y-axis of other plots.
Nevertheless, here's a homemade pairs_cutoff() function doing what you want.
pairs_cutoff <- function(data, cutoff, cols = c("red", "blue"),
only.lower = F, ...){
data <- as.data.frame(data)
cns <- colnames(data)
nc <- ncol(data)
layout(matrix(seq_len(nc^2), ncol = nc))
invisible(
sapply(seq_len(nc), function(i){
sapply(seq_len(nc), function(j){
if(i == j){
plot.new()
legend("center", bty = "n", title = cns[i], cex = 1.5, text.font = 2, legend = "")
} else {
if(j < i & only.lower)
plot.new()
else{
if(is.null(cutoff))
cols <- cols[1]
plot(data[,i], data[,j], col = cols[(data[,i] < cutoff) + 1],
xlab = cns[i], ylab = cns[j], ...)
}
}
})
})
)
}
Using your suggested data :
n = 1000
dat <- tibble(
xx1 = runif(n, min = 3, max = 10),
xx2 = runif(n, min = 3, max = 10),
xx3 = runif(n, min = 3, max = 10)
)
pairs_cutoff(dat, cutoff = 5, only.lower = T)
outputs the following plot :
You can specify extra parameters to the plot function (eg. pch) directly to pairs_cutoff.
Also, if you want the full symmetric grid of plots, set only.lower = F.
I'm using the function gammamixEM from the package mixtools. How can I return the graphical output of density as in the function normalmixEM (i.e., the second plot in plot(...,which=2)) ?
Update:
Here is a reproducible example for the function gammamixEM:
x <- c(rgamma(200, shape = 0.2, scale = 14), rgamma(200,
shape = 32, scale = 10), rgamma(200, shape = 5, scale = 6))
out <- gammamixEM(x, lambda = c(1, 1, 1)/3, verb = TRUE)
Here is a reproducible example for the function normalmixEM:
data(faithful)
attach(faithful)
out <- normalmixEM(waiting, arbvar = FALSE, epsilon = 1e-03)
plot(out, which=2)
I would like to obtain this graphical output of density from the function gammamixEM.
Here you go.
out <- normalmixEM(waiting, arbvar = FALSE, epsilon = 1e-03)
x <- out
whichplots <- 2
density = 2 %in% whichplots
loglik = 1 %in% whichplots
def.par <- par(ask=(loglik + density > 1), "mar") # only ask and mar are changed
mix.object <- x
k <- ncol(mix.object$posterior)
x <- sort(mix.object$x)
a <- hist(x, plot = FALSE)
maxy <- max(max(a$density), .3989*mix.object$lambda/mix.object$sigma)
I just had to dig into the source code of plot.mixEM
So, now to do this with gammamixEM:
x <- c(rgamma(200, shape = 0.2, scale = 14), rgamma(200,
shape = 32, scale = 10), rgamma(200, shape = 5, scale = 6))
gammamixEM.out <- gammamixEM(x, lambda = c(1, 1, 1)/3, verb = TRUE)
mix.object <- gammamixEM.out
k <- ncol(mix.object$posterior)
x <- sort(mix.object$x)
a <- hist(x, plot = FALSE)
maxy <- max(max(a$density), .3989*mix.object$lambda/mix.object$sigma)
main2 <- "Density Curves"
xlab2 <- "Data"
col2 <- 2:(k+1)
hist(x, prob = TRUE, main = main2, xlab = xlab2,
ylim = c(0,maxy))
for (i in 1:k) {
lines(x, mix.object$lambda[i] *
dnorm(x,
sd = sd(x)))
}
I believe it should be pretty straight forward to continue this example a bit, if you want to add the labels, smooth lines, etc. Here's the source of the plot.mixEM function.
I need to compute the efficient frontier with different risk measure and to use a bootstrapping technique to simulate possible outcome. However, now I'm stuck: what I want to do is to generate via a loop (which will be integrated later into a function) multiple efficient frontier, each one associated to a possible future outcome, and to plot them on the same figure in such a way to see how they may change as the simulation goes on. Here is the loop that I wrote so far:
for (i in 1:B) {
idx <- sample(1:N, N, replace = TRUE)
new.x <- x[idx, ]
µ.b <- apply(X = new.x, 2, FUN = mean)
range.b[, i] <- seq(from = min(µ.b), to = max(µ.b), length.out = steps)
sigma.b <- apply(X = new.x, 2, FUN = sd)
riskCov.b[, i] <- sapply(range.b[, i], function(targetReturn) {
w <- MV_QP(new.x, targetReturn, Sigma)
sd(c(new.x %*% w))
})
xlim.b <- range(c(sigma.b, riskCov.b[, 1]), na.rm = TRUE)
ylim.b <- range(µ.b)
par(new = TRUE)
plot(x = riskCov.b[, i], y = range.b[, i], type = "l", xlim = xlim.b, ylim = ylim.b, xlab = "Risk", ylab = "Return", main = "Resampling EFs")
}
but the problem is that the elements on the x and y axis are rewriting each time the loop runs. How can this problem be solved?
I don't nknow if the optimization is correct. For ploting you can try the following:
for (i in 1:B) {
idx <- sample(1:N, N, replace = TRUE)
new.x <- x[idx, ]
µ.b <- apply(X = new.x, 2, FUN = mean)
range.b[, i] <- seq(from = min(µ.b), to = max(µ.b), length.out = steps)
#sigma.b <- apply(X = new.x, 2, FUN = sd)
riskCov.b[, i] <- sapply(range.b[, i], function(targetReturn) {
w <- MV_QP(new.x, targetReturn,Sigma=cov(new.x))
sd(c(new.x %*% w))
})
}
xlim.b <- range(c(apply(X = x, 2, FUN= sd), riskCov.b), na.rm = TRUE) *c(0.98,1.02)
ylim.b <- range(µ.b) *c(0.98,1.02)
#par(new = TRUE)
for (i in 1:B){
if (i==1) plot(x = riskCov.b[, i], y = range.b[, i], type = "l", xlim = xlim.b, ylim = ylim.b, xlab = "Risk", ylab = "Return", main = "Resampling EFs") else
lines(x = riskCov.b[, i], y = range.b[, i],col=rainbow(B)[i])
}
Depending on your data, you should end up with a similar plot:
I'm trying to run a simulation of the wright-fisher model of genetic drift in R.
# Wright-Fisher simulation
# n = number of individuals
# f = number of focal alleles at base population
n=10
f=1
pop = as.matrix( c( rep(0,n-f), rep(1,f) ) )
pop = as.matrix( sample(pop, n, replace=T) )
This works, effectively this is one replicate, and each time I run the final line of script is a new generation. What I would like to do, but can't, is have a loop which automatically loops it for X generations and repeat for Y number of replicates.
It should store the results for each generation in a dataframe and then allow me to plot them in a graph which looks something like this (where f/n is allele frequency, each replicate is represented by one line, and the number of generations determines the length of the X axis)...
Here is a function I wrote a few years ago. You can set the pop size, generations to simulate for, and replicates.
Since you haven't shown any code of your own, I'll leave it up to you to figure out how to store output. At any rate, this should get you going:
Drift_graph = function(t,R){
N<-250
p<-0.5
freq<-as.numeric();
for( i in 1:t ){
A1=rbinom(1,2*N,p)
p=A1/(N*2);
freq[length(freq)+1]<-p;
}
plot(freq,type="l",ylim=c(0,1),col=3,xlab="t",ylab=expression(p(A[1])))
for(u in 1:R){
freq1<-as.numeric();
p<-0.5
for( j in 1:t ){
A1=rbinom(1,2*N,p)
p=A1/(N*2);
freq1[length(freq1)+1]<-p;
}
random<-sample(1:1000,1,replace=F)
randomcolor<-colors()[random]
lines(freq1,type="l",col=(randomcolor))
}
}
Drift_graph(2000,50)
# Pop = Replicate populations
# Gen = Generations
# NM = Male population size
# NF = Female population size
# P = Frequency of focal allele
GenDriftSim = function(Pop = Pop, Gen = Gen, NM, NF, P, graph = "y", histo = "y"){
P = (2*(NM+NF))*P
NE = round((4*NM*NF)/(NM+NF),0)
SR = round(NM/NF,2)
Na = NM+NF
if(graph=="y"){
plot(c(0,0),type = "n", main = bquote('N'[M]~'/ N'[F]~'='~.(SR)*', N'[A]~'='~.(Na)*', N'[E]~'='~.(NE)), cex.main = 1,
xlim = c(1,Gen), ylim=c(0,1), xlab = "Generations", ylab = "Fequency of focal allele")
}else{}
for (i in 1:Pop){
N = NM+NF
startA = as.vector(c(rep(1, times = P),rep(0, times = (2*N)-P)))
Population = matrix(c(
c(sample(startA, size = 2*N, replace = FALSE)),
c(rep("M", times = NM), rep("F", times = NF))),
ncol = 3)
SimResults[(Gen*i)+1-Gen, 3] <<- sum(as.numeric(Population[,1:2]))/(N*2)
for(j in 1:(Gen-1)){
Population = matrix(c(
c(sample(sample(Population[(1:NM),1:2], replace = TRUE),N, replace = TRUE)),
c(sample(sample(Population[(1+NM):N,1:2], replace = TRUE),N, replace = TRUE)),
c(rep("M", times = NM), rep("F", times = NF))), ncol = 3)
SimResults[(Gen*i)+1+j-Gen, 3] <<- sum(as.numeric(Population[,1:2]))/(N*2)
}
s = (i*Gen)-Gen+1; e = i*Gen
r = as.vector(SimResults[s:e, 3])
if(graph=="y"){
points(r~c(1:Gen), type = "l")
}else{}
}
if(histo == "y"){SimResults[,1] = rep(1:Pop, each = Gen)
SimResults[,2] = rep(1:Gen, times = Pop)
hist(SimResults[,3][SimResults[,2]==Gen], breaks = 100, cex.lab = 0.7, cex.axis = 0.7, xlim = c(0,1), cex.main = 1, main = bquote('N'[M]~'/ N'[F]~'='~.(SR)*', N'[A]~'='~.(Na)*', N'[E]~'='~.(NE)), xlab = paste0("Frequency of focal allele after ",Gen," Generations"))
}else{}
}
Pop = 10
Gen = 25
P = 0.5
SimResults = matrix(data = NA, ncol = 3, nrow = Gen*Pop)
GenDriftSim(Pop = Pop, Gen = Gen, NM = 100, NF = 900, P = P, graph = "y", histo = "n")
GenDriftSim(Pop = Pop, Gen = Gen, NM = 180, NF = 180, P = P, graph = "y", histo = "n")
dev.off()