Plot multiple graphs in one figure using a loop - r

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:

Related

get(paste0(...)) overwrites results in R subarray

I have two subarrays and would like to sample one of them at random. The subarrays consist of character labels from a larger pool of labels as follows:
K <- as.character(1:10)
Suppose I call the arrays K1 and K2 and assign 10 labels between them as follows:
K1 <- 1:8
K2 <- 9:10
I then use
get(paste0("K", i))
to retrieve the labels that were sampled using a 'for' loop.
The issue I am having is this: if K1 is sampled, get(paste0("K", i)) returns labels from K2 (which contain labels 9:10) instead of returning K1 as needed.
In other words, I believe get(past0("K", i)) may be overwriting results.
Any thoughts on why this may occur and how to go about circumventing the issue?
Below is a more extensive example:
K <- 2
N <- 100
Hstar <- 10
perms <- 10000
probs <- rep(1/Hstar, Hstar)
specs <- 1:N
pop <- array(dim = c(c(perms, N), K))
haps <- as.character(1:Hstar)
K1 <- 1:8 # subarray 1
K2 <- 9:10 # subarray 2
for(j in 1:perms){
for(i in 1:K){
if(i == 1){
pop[j, specs, i] <- sample(haps, size = N, replace = TRUE, prob = probs)
}
else{
pop[j ,, 1] <- sample(haps[K1], size = N, replace = TRUE, prob = probs[K1])
pop[j ,, 2] <- sample(haps[K2], size = N, replace = TRUE, prob = probs[K1])
}
}
}
HAC.mat <- array(dim = c(c(perms, N), K))
for(k in specs){
for(j in 1:perms){
for(i in 1:K){
ind.index <- sample(specs, size = k, replace = FALSE)
hap.plot <- pop[sample(1:nrow(pop), size = 1, replace = TRUE), ind.index, sample(i, size = 1, replace = TRUE)]
HAC.mat[j, k, i] <- length(unique(hap.plot))
}
}
}
means <- apply(HAC.mat, MARGIN = 2, mean)
lower <- apply(HAC.mat, MARGIN = 2, function(x) quantile(x, 0.025))
upper <- apply(HAC.mat, MARGIN = 2, function(x) quantile(x, 0.975))
d <- data.frame(specs, means, lower, upper)
par(mfrow = c(1, 2))
if(i == 1){
plot(specs, means, type = "n", xlab = "Specimens sampled", ylab = "Unique haplotypes", ylim = c(1, Hstar))
polygon(x = c(specs, rev(specs)), y = c(lower, rev(upper)), col = "gray")
lines(specs, means, lwd = 2)
HAC.bar <- barplot(N*probs, xlab = "Unique haplotypes", ylab = "Specimens sampled", names.arg = 1:Hstar)
}
else if(i > 1){
plot(specs, means, type = "n", xlab = "Specimens sampled", ylab = "Unique haplotypes", ylim = c(1, Hstar))
polygon(x = c(specs, rev(specs)), y = c(lower, rev(upper)), col = "gray")
lines(specs, means, lwd = 2)
HAC.bar <- barplot(N*probs[get(paste0("K", i))], xlab = "Unique haplotypes", ylab = "Specimens sampled", names.arg = get(paste0("K", i))) ## The issue may lie here
}
Any advice on what may be going on here is greatly appreciated.

Having a function output two quantities in looping structure in R?

In my R function below, I'm wondering how I can change my code such that I can get pe out of my fun function? Right now, fun only outputs L and U.
P.S. Of course, I want to keep the function work as it does right now, so therefore replicate may also need to change as a result of having fun output pe in addition to L and U.
CI.bi = function(n, p, n.sim){
fun <- function(n1 = n, p1 = p){
x <- rbinom(1, size = n1, prob = p1)
pe <- x/n1
res <- binom.test(x, n1, p1)[[4]]
c(L = res[1], U = res[2])
}
sim <- t(replicate(n.sim, fun()))
y = unlist(lapply(1:n.sim, function(x) c(x, x)))
plot(sim, y, ty = "n", ylab = NA, yaxt = "n")
segments(sim[ ,1], 1:n.sim, sim[ ,2], 1:n.sim, lend = 1)
}
# Example of use:
CI.bi(n = 15, p = .5, n.sim = 3)
You can have fun() return pe as an additional element of the return vector.
When referencing sim later on, just specify which columns you want to use. I believe the below code sample replicates your current functionality but has pe as an additional output of fun()
CI.bi = function(n, p, n.sim){
fun <- function(n1 = n, p1 = p){
x <- rbinom(1, size = n1, prob = p1)
pe <- x/n1
res <- binom.test(x, n1, p1)[[4]]
c(L = res[1], U = res[2], pe=pe)
}
sim <- t(replicate(n.sim, fun()))
y = unlist(lapply(1:n.sim, function(x) c(x, x)))
plot(sim[,1:2], y, ty = "n", ylab = NA, yaxt = "n")
segments(sim[ ,1], 1:n.sim, sim[ ,2], 1:n.sim, lend = 1)
}
CI.bi(n = 15, p = .5, n.sim = 3)

BTYD package. error in bgnbd plotting: need finite 'ylim' values for frequency in calibration

I'm having some trouble when plotting the "bgnbd.PlotFrequencyInCalibration" in the "BTYD" package.
There is no NA in the dataset and other plots works without error.
Below is my code for the plots:
CustData<- read.csv("~/ltv/CustData")
> cal.cbs<-cbind(CustData$t.x,CustData$x,CustData$T.cal,CustData$x.star)
> colnames(cal.cbs)<-c("t.x","x","T.cal","x.star")
est.params<-c(0.0313,0.9165,1.088,0.7903)
bgnbd.PlotFrequencyInCalibration(est.params,cal.cbs,7)
Error in plot.window(xlim, ylim, log = log, ...) :
need finite 'ylim' values
Any help would be appreciated. Thank you.
Kara
subset of the data
I fixed for pnbd.pnbd.PlotFrequencyInCalibration. Repeat the same for bgnbd. If you look at the actual function for pnbd.PlotFrequencyInCalibration :
"https://github.com/cran/BTYD/blob/master/R/pnbd.R" (check here)
pnbd.PlotFrequencyInCalibration <- function(params, cal.cbs, censor, plotZero = TRUE,
xlab = "Calibration period transactions", ylab = "Customers", title = "Frequency of Repeat Transactions") {
tryCatch(x <- cal.cbs[, "x"], error = function(e) stop("Error in pnbd.PlotFrequencyInCalibration: cal.cbs must have a frequency column labelled \"x\""))
tryCatch(T.cal <- cal.cbs[, "T.cal"], error = function(e) stop("Error in pnbd.PlotFrequencyInCalibration: cal.cbs must have a column for length of time observed labelled \"T.cal\""))
dc.check.model.params(c("r", "alpha", "s", "beta"), params, "pnbd.PlotFrequencyInCalibration")
if (censor > max(x))
stop("censor too big (> max freq) in PlotFrequencyInCalibration.")
n.x <- rep(0, max(x) + 1)
custs = nrow(cal.cbs)
for (ii in unique(x)) {
n.x[ii + 1] <- sum(ii == x)
}
n.x.censor <- sum(n.x[(censor + 1):length(n.x)])
n.x.actual <- c(n.x[1:censor], n.x.censor)
T.value.counts <- table(T.cal)
T.values <- as.numeric(names(T.value.counts))
n.T.values <- length(T.values)
total.probability <- 0
n.x.expected <- rep(0, length(n.x.actual))
for (ii in 1:(censor)) {
this.x.expected <- 0
for (T.idx in 1:n.T.values) {
T <- T.values[T.idx]
if (T == 0)
next
n.T <- T.value.counts[T.idx]
expected.given.x.and.T <- n.T * pnbd.pmf(params, T, ii - 1)
this.x.expected <- this.x.expected + expected.given.x.and.T
total.probability <- total.probability + expected.given.x.and.T/custs
}
n.x.expected[ii] <- this.x.expected
}
n.x.expected[censor + 1] <- custs * (1 - total.probability)
col.names <- paste(rep("freq", length(censor + 1)), (0:censor), sep = ".")
col.names[censor + 1] <- paste(col.names[censor + 1], "+", sep = "")
censored.freq.comparison <- rbind(n.x.actual, n.x.expected)
colnames(censored.freq.comparison) <- col.names
cfc.plot <- censored.freq.comparison
if (plotZero == FALSE)
cfc.plot <- cfc.plot[, -1]
n.ticks <- ncol(cfc.plot)
if (plotZero == TRUE) {
x.labels <- 0:(n.ticks - 1)
x.labels[n.ticks] <- paste(n.ticks - 1, "+", sep = "")
} else {
x.labels <- 1:(n.ticks)
x.labels[n.ticks] <- paste(n.ticks, "+", sep = "")
}
ylim <- c(0, ceiling(max(cfc.plot,na.rm = TRUE) * 1.1))
barplot(cfc.plot, names.arg = x.labels, beside = TRUE, ylim = ylim, main = title,
xlab = xlab, ylab = ylab, col = 1:2)
legend("topright", legend = c("Actual", "Model"), col = 1:2, lwd = 2)
return(censored.freq.comparison)
}
There is a line:
ylim <- c(0, ceiling(max(cfc.plot) * 1.1))
Add to it, na.rm=TRUE
ylim <- c(0, ceiling(max(cfc.plot,na.rm = TRUE) * 1.1))
Run the function again, should work now

define breaks for hist2d in R

is there a simple way to define breaks instead of nbins for a 2d histogram (hist2d) in R?
I want to define the range for the x- and yaxis for a 2D histogram and the number of bins for each dimension.
My example:
# example data
x <- sample(-1:100, 2000, replace=T)
y <- sample(0:89, 2000, replace=T)
# create 2d histogram
h2 <- hist2d(x,y,nbins=c(23,19),xlim=c(-1,110), ylim=c(0,95),xlab='x',ylab='y',main='hist2d')
This results in this 2D histogram output 1
----------------------------
2-D Histogram Object
----------------------------
Call: hist2d(x = x, y = y, nbins = c(23, 19), xlab = "x", ylab = "y",
xlim = c(-1, 110), ylim = c(0, 95), main = "hist2d")
Number of data points: 2000
Number of grid bins: 23 x 19
X range: ( -1 , 100 )
Y range: ( 0 , 89 )
I need
X range: ( -1 , 110 )
Y range: ( 0 , 95 )
instead.
My attempt to define the xlim and ylim only extends the plot but does not define the axis range for the histogram. I know that there would be no data in the additional bins.
Is there a way to define
xbreaks = seq(-1,110,5)
ybreaks = seq(0,95,5)
instead of using nbins which divides the range from minimum to maximum into the given number of bins?
Thank you for your help
I changed the code a little bit and this version should work the with explicitly defining the breaks for both axes. First you have to load the function. Then you can give the x.breaks and y.breaks options with x.breaks=seq(0,10,0.1).
If same.scale is true, you only need x.breaks
The return value addionaly contains the number of bins and the relative counts.
Also, you can include a legend if wanted, by setting legend=TRUE. For that you need to have the package Fields
hist2d_breaks = function (x, y = NULL, nbins = 200,same.scale = FALSE, na.rm = TRUE,
show = TRUE, col = c("black", heat.colors(12)), FUN = base::length,
xlab, ylab,x.breaks,y.breaks, ...)
{
if (is.null(y)) {
if (ncol(x) != 2)
stop("If y is ommitted, x must be a 2 column matirx")
y <- x[, 2]
x <- x[, 1]
}
if (length(nbins) == 1)
nbins <- rep(nbins, 2)
nas <- is.na(x) | is.na(y)
if (na.rm) {
x <- x[!nas]
y <- y[!nas]
}
else stop("missinig values not permitted if na.rm=FALSE")
if(same.scale){
x.cuts = x.breaks;
y.cuts = x.breaks;
}else{
x.cuts <- x.breaks
y.cuts <- y.breaks
}
index.x <- cut(x, x.cuts, include.lowest = TRUE)
index.y <- cut(y, y.cuts, include.lowest = TRUE)
m <- tapply(x, list(index.x, index.y), FUN)
if (identical(FUN, base::length))
m[is.na(m)] <- 0
if (missing(xlab))
xlab <- deparse(substitute(xlab))
if (missing(ylab))
ylab <- deparse(substitute(ylab))
if (show){
if(legend){
image.plot(x.cuts, y.cuts, m, col = col, xlab = xlab, ylab = ylab,
...)
}else{
image(x.cuts, y.cuts, m, col = col, xlab = xlab, ylab = ylab,
...)
}
}
midpoints <- function(x) (x[-1] + x[-length(x)])/2
retval <- list()
retval$counts <- m
retval$counts_rel <- m/max(m)
retval$x.breaks = x.cuts
retval$y.breaks = y.cuts
retval$x = midpoints(x.cuts)
retval$y = midpoints(y.cuts)
retval$nobs = length(x)
retval$bins = c(length(x.cuts),length(y.cuts))
retval$call <- match.call()
class(retval) <- "hist2d"
retval
}
The call of (my data) then brings the following:
hist2d_breaks(df,x.breaks=seq(0,10,1),y.breaks=seq(-10,10,1),legend=TRUE)
brings up the following plot
2D Histogram with breaks
Revise the "hist2d" as follows
hist2d_range<-function (x, y = NULL, nbins = 200, same.scale = TRUE, na.rm = TRUE,
show = TRUE, col = c("black", heat.colors(12)), FUN = base::length,
xlab, ylab,range=NULL, ...)
{
if (is.null(y)) {
if (ncol(x) != 2)
stop("If y is ommitted, x must be a 2 column matirx")
y <- x[, 2]
x <- x[, 1]
}
if (length(nbins) == 1)
nbins <- rep(nbins, 2)
nas <- is.na(x) | is.na(y)
if (na.rm) {
x <- x[!nas]
y <- y[!nas]
}
else stop("missinig values not permitted if na.rm=FALSE")
if (same.scale) {
if(is.null(range))
{
x.cuts <- seq(from = min(x, y), to = max(x, y), length = nbins[1] +
1)
y.cuts <- seq(from = min(x, y), to = max(x, y), length = nbins[2] +
1)
}else{
x.cuts <- seq(from = range[1], to = range[2], length = nbins[1] + 1)
y.cuts <- seq(from = range[1], to = range[2], length = nbins[1] + 1)
}
}
else {
x.cuts <- seq(from = min(x), to = max(x), length = nbins[1] +
1)
y.cuts <- seq(from = min(y), to = max(y), length = nbins[2] +
1)
}
index.x <- cut(x, x.cuts, include.lowest = TRUE)
index.y <- cut(y, y.cuts, include.lowest = TRUE)
m <- tapply(x, list(index.x, index.y), FUN)
if (identical(FUN, base::length))
m[is.na(m)] <- 0
if (missing(xlab))
xlab <- deparse(substitute(xlab))
if (missing(ylab))
ylab <- deparse(substitute(ylab))
if (show)
image(x.cuts, y.cuts, m, col = col, xlab = xlab, ylab = ylab,
...)
midpoints <- function(x) (x[-1] + x[-length(x)])/2
retval <- list()
retval$counts <- m
retval$x.breaks = x.cuts
retval$y.breaks = y.cuts
retval$x = midpoints(x.cuts)
retval$y = midpoints(y.cuts)
retval$nobs = length(x)
retval$call <- match.call()
class(retval) <- "hist2d"
retval
}
This function has an additional argument "range".
The revised point is as follows.
if(is.null(range))
{
x.cuts <- seq(from = min(x, y), to = max(x, y), length = nbins[1] +
1)
y.cuts <- seq(from = min(x, y), to = max(x, y), length = nbins[2] +
1)
}else{
x.cuts <- seq(from = range[1], to = range[2], length = nbins[1] + 1)
y.cuts <- seq(from = range[1], to = range[2], length = nbins[1] + 1)
}

How to isolate the plots of this method?

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)

Resources