Arranging Plots from TraMineR and seqHMM - r

I want to plot two sequence distribution plots with the TraMineR package (seqplot(type = 'd')) and below them two Hidden Markov Models which correspond to the sequence plots (those are clusters).
For the reprex, I just use the build in biofam data set. Using layout() produces the desired result up to the third plot. The fourth plot is drawn to a new page, so essentially the bottom right space is left empty, but the first three panes are used accordingly to the layout() specs.
library('seqHMM')
library('TraMineR')
data("biofam")
biofam <- biofam[sample(nrow(biofam),300),]
biofam.lab <- c("Parent", "Left", "Married", "Left+Marr",
"Child", "Left+Child", "Left+Marr+Child", "Divorced")
biofam.seq <- seqdef(biofam, 10:25, labels=biofam.lab)
#> [>] 8 distinct states appear in the data:
#> 1 = 0
#> 2 = 1
#> 3 = 2
#> 4 = 3
#> 5 = 4
#> 6 = 5
#> 7 = 6
#> 8 = 7
#> [>] state coding:
#> [alphabet] [label] [long label]
#> 1 0 0 Parent
#> 2 1 1 Left
#> 3 2 2 Married
#> 4 3 3 Left+Marr
#> 5 4 4 Child
#> 6 5 5 Left+Child
#> 7 6 6 Left+Marr+Child
#> 8 7 7 Divorced
#> [>] 300 sequences in the data set
#> [>] min/max sequence length: 16/16
### Plot the sequence
seqplot(biofam.seq,type='d',with.legend=FALSE)
### Fit a Hidden Markov Model
biofam.hmm <- build_hmm(observations = biofam.seq, n_states = 3)
### Plot the HMM once
plot(biofam.hmm, with.legend=FALSE)
### Use layout to plot two sequence distribution plots and below there HMM
layout(matrix(c(1,2,3,4), ncol = 2, byrow = TRUE))
layout.show(4)
par(cex = 0.65, mar = c(2.5,4.1,2.5,1.5))
### The Sequence plots
seqplot(biofam.seq, type = 'd', with.legend = FALSE, border = NA, ylab = NA)
seqplot(biofam.seq, type = 'd', with.legend = FALSE, border = NA, ylab = NA)
### Change the par() arguments
par(cex = 0.5, mar = c(1.5,3.5,3.5,1.5))
plot(biofam.hmm, with.legend = FALSE, vertex.size = 15)
plot(biofam.hmm, with.legend = FALSE, vertex.size = 15)
Created on 2022-11-20 by the reprex package (v2.0.1)
As you can see, the layout.show() indicates the correct plotting dimensions, but the second HMM plot is drawn on the next pane. Is there anything I can do (besides from plotting one cluster after another with just the sequence distribution and the fitted HMM), to plot everything on one page?
Any help would be appreciated.
Kind regards
PS: Since I don't have enough reputation, I cannot include the rendered images. Hopefully you can recreate my issue with the given code by yourself.

The problem is that seqHMM:::plot.hmm―the method which is dispatched when calling plot on a "hmm" object―is messing around with the pars internally (bad practice). But we can modify the method by deactivating that behavior, and have a new plot_hmm function.
plot_hmm <- function(x, layout = "horizontal", pie = TRUE, vertex.size = 40,
vertex.label = "initial.probs", vertex.label.dist = "auto",
vertex.label.pos = "bottom", vertex.label.family = "sans",
loops = FALSE, edge.curved = TRUE, edge.label = "auto", edge.width = "auto",
cex.edge.width = 1, edge.arrow.size = 1.5, edge.label.family = "sans",
label.signif = 2, label.scientific = FALSE, label.max.length = 6,
trim = 1e-15, combine.slices = 0.05, combined.slice.color = "white",
combined.slice.label = "others", with.legend = "bottom",
ltext = NULL, legend.prop = 0.5, cex.legend = 1, ncol.legend = "auto",
cpal = "auto", cpal.legend = "auto", legend.order = TRUE,
main = NULL, withlegend, ...) {
seqHMM:::check_deprecated_args(match.call())
oldPar <- par(no.readonly = TRUE)
if (is.null(main)) {
par(mar = c(0.5, 0.5, 0.5, 0.5))
}
else {
par(mai = c(0, 0, 1, 0))
}
# on.exit(par(oldPar), add = TRUE)
# on.exit(par(mfrow = c(1, 1)), add = TRUE)
dots <- list(...)
labelprint <- function(z, labs) {
if (labs == TRUE && (z > 0.001 || z == 0)) {
labs <- FALSE
}
if (z < 10^-(label.max.length)) {
z <- prettyNum(signif(round(z, digits = label.max.length),
digits = label.signif), scientific = labs)
}
else {
z <- prettyNum(signif(z, digits = label.signif),
scientific = labs)
}
}
if (!is.matrix(layout) && !is.function(layout)) {
if (!(layout %in% c("horizontal", "vertical"))) {
stop("Argument layout only accepts numerical matrices, igraph layout functions, or strings \"horizontal\" and \"vertical\".")
}
}
if (!is.numeric(vertex.label.pos)) {
choices <- c("bottom", "top", "left", "right")
ind <- pmatch(vertex.label.pos, choices, duplicates.ok = TRUE)
if (any(is.na(ind))) {
stop("Argument vertex.label.pos only accepts values \"bottom\", \"top\", \"left\", \"right\" or a numerical vector.")
}
vertex.label.pos <- choices[ind]
}
choices <- c(TRUE, FALSE, "bottom", "top", "left", "right")
ind <- pmatch(with.legend, choices)
if (is.na(ind)) {
stop("Argument with.legend must be one of TRUE, FALSE, \"bottom\", \"right\", \"top\", or \"left\".")
}
with.legend <- choices[ind]
if (with.legend %in% c(TRUE, "auto")) {
with.legend <- "bottom"
}
if (x$n_channels > 1) {
x <- mc_to_sc(x)
}
if (pie == FALSE && with.legend != FALSE) {
with.legend <- FALSE
}
if (!is.numeric(vertex.label.pos)) {
vpos <- numeric(length(vertex.label.pos))
for (i in 1:length(vertex.label.pos)) {
if (vertex.label.pos[i] == "bottom") {
vpos[i] <- pi/2
}
else if (vertex.label.pos[i] == "top") {
vpos[i] <- -pi/2
}
else if (vertex.label.pos[i] == "left") {
vpos[i] <- pi
}
else {
vpos[i] <- 0
}
}
vertex.label.pos <- vpos
}
if (length(vertex.label) == 1 && !is.na(vertex.label) &&
vertex.label != FALSE) {
if (vertex.label == "initial.probs") {
vertex.label <- sapply(x$initial_probs, labelprint,
labs = label.scientific)
}
else if (vertex.label == "names") {
vertex.label <- x$state_names
}
}
else if (length(vertex.label) != length(x$state_names)) {
warning("The length of the vector provided for the argument \"vertex.label\" does not match the number of hidden states.")
vertex.label <- rep(vertex.label, length.out = length(x$state_names))
}
if (is.character(vertex.label.dist)) {
ind <- pmatch(vertex.label.dist, "auto")
if (is.na(ind)) {
stop("Argument vertex.label.dist only accepts the value \"auto\" or a numerical vector.")
}
vertex.label.dist <- vertex.size * 0.4/3.5
}
else if (length(vertex.label.dist) > 1 && length(vertex.label.dist) !=
x$n_states) {
warning("The length of the vector provided for the argument \"vertex.label.dist\" does not match the number of edges.")
vertex.label.dist <- rep(vertex.label.dist, length.out = length(x$n_states))
}
transM <- x$transition_probs
transM[transM < trim] <- 0
edges <- transM
edges[edges > 0] <- 1
if (!loops) {
diag(edges) <- 0
}
transitions <- transM
if (loops == FALSE && length(transitions) > 1) {
diag(transitions) <- 0
}
transitions <- t(transitions)[t(transitions) > 0]
if (!is.na(edge.label) && edge.label != FALSE) {
if (length(edge.label) == 1 && (edge.label == "auto" ||
edge.label == TRUE)) {
edge.label <- sapply(transitions, labelprint, labs = label.scientific)
}
else if (length(edge.label) > 1 && length(edge.label) !=
length(transitions)) {
warning("The length of the vector provided for the argument \"edge.label\" does not match the number of edges.")
edge.label <- rep(edge.label, length.out = length(transitions))
}
}
if (is.character(edge.width)) {
ind <- pmatch(edge.width, "auto")
if (is.na(ind)) {
stop("Argument edge.width only accepts the value \"auto\" or a numerical vector.")
}
edge.width <- transitions * (7/max(transitions)) * cex.edge.width
}
else if (length(edge.width) > 1 && edge.width != length(transitions)) {
warning("The length of the vector provided for the argument \"edge.width\" does not match the number of edges.")
edge.width <- rep(edge.width, length.out = length(transitions))
}
g1 <- igraph::graph.adjacency(edges, mode = "directed")
if (is.function(layout)) {
glayout <- layout(g1)
}
else if (is.matrix(layout)) {
glayout <- layout
}
else {
if (layout == "horizontal") {
glayout <- igraph::layout_on_grid(g1, width = x$n_states)
}
else if (layout == "vertical") {
glayout <- igraph::layout_on_grid(g1, width = 1)
}
}
if (length(cpal) == 1 && cpal == "auto") {
pie.colors <- attr(x$observations, "cpal")
}
else if (length(cpal) != ncol(x$emiss)) {
warning("The length of the vector provided for argument cpal does not match the number of observed states. Automatic color palette was used.")
pie.colors <- attr(x$observations, "cpal")
}
else if (!all(isColor(cpal))) {
stop(paste("Please provide a vector of colors for argument cpal or use value \"auto\" for automatic color palette."))
}
else {
pie.colors <- cpal
}
if (with.legend != FALSE) {
pie.colors.l <- pie.colors
}
if (with.legend != FALSE && pie == TRUE) {
if (!is.null(ltext)) {
if (legend.order) {
if (length(ltext) != x$n_symbols) {
stop(paste0("With legend.order = TRUE, the length of the argument ltext must match the number of (combined) observed states in the observed data (",
x$n_symbols, ")."))
}
}
else {
if ((length(cpal) == 1 && cpal != "auto") &&
length(ltext) != length(cpal.legend)) {
stop(paste0("The number of colours in cpal.legend does not match the number of labels in ltext."))
}
ltext.orig <- ltext
if (length(cpal) == 1 && cpal == "auto") {
if (length(cpal.legend) == 1 && cpal.legend ==
"auto") {
cpal.legend <- attr(x$observations, "cpal")
}
}
else {
if (length(cpal.legend) == 1 && cpal.legend ==
"auto") {
cpal.legend <- cpal
}
}
}
}
else {
ltext <- ltext.orig <- x$symbol_names
if (length(cpal) == 1 && cpal == "auto") {
if (length(cpal.legend) == 1 && cpal.legend ==
"auto") {
cpal.legend <- attr(x$observations, "cpal")
}
}
else {
cpal.legend <- cpal
}
}
if (with.legend == "bottom") {
graphics::layout(matrix(1:2, nrow = 2), heights = c(1 -
legend.prop, legend.prop))
}
else if (with.legend == "right") {
graphics::layout(matrix(1:2, nrow = 1), widths = c(1 -
legend.prop, legend.prop))
}
else if (with.legend == "left") {
graphics::layout(matrix(2:1, nrow = 1), widths = c(legend.prop,
1 - legend.prop))
}
else {
graphics::layout(matrix(2:1, nrow = 2), widths = c(legend.prop,
1 - legend.prop))
}
par(cex = 1)
}
if (!is.matrix(layout) && !is.function(layout)) {
if (layout == "horizontal") {
if (hasArg(rescale)) {
rescale <- dots$rescale
}
else {
rescale <- FALSE
}
if (hasArg(xlim)) {
xlim <- dots$xlim
}
else {
if (rescale == TRUE) {
xlim <- c(-1, 1)
}
else {
xlim <- c(-0.1, ncol(transM) - 1 + 0.1)
}
}
if (hasArg(ylim)) {
ylim <- dots$ylim
}
else {
if (rescale == TRUE) {
ylim <- c(-1, 1)
}
else {
ylim <- c(-0.5, 0.5)
}
}
dots[["xlim"]] <- NULL
dots[["ylim"]] <- NULL
dots[["rescale"]] <- NULL
}
else if (layout == "vertical") {
if (hasArg(rescale)) {
rescale <- dots$rescale
}
else {
rescale <- FALSE
}
if (hasArg(xlim)) {
xlim <- dots$xlim
}
else {
if (rescale == TRUE) {
xlim <- c(-1, 1)
}
else {
xlim <- c(-0.5, 0.5)
}
}
if (hasArg(ylim)) {
ylim <- dots$ylim
}
else {
if (rescale == TRUE) {
ylim <- c(-1, 1)
}
else {
ylim <- c(-0.1, ncol(transM) - 1 + 0.1)
}
}
dots[["xlim"]] <- NULL
dots[["ylim"]] <- NULL
dots[["rescale"]] <- NULL
}
}
if (pie == TRUE) {
pie.values <- lapply(seq_len(nrow(transM)), function(i) x$emission_probs[i,
])
if (combine.slices > 0 && !all(unlist(pie.values)[unlist(pie.values) >
0] > combine.slices)) {
if (with.legend != FALSE) {
pie.colors.l <- NULL
lt <- NULL
}
for (i in 1:x$n_states) {
cs.prob <- sum(pie.values[[i]][pie.values[[i]] <
combine.slices])
pie.values[[i]][pie.values[[i]] < combine.slices] <- 0
pie.values[[i]] <- c(pie.values[[i]], cs.prob)
if (with.legend != FALSE) {
pie.colors.l <- c(pie.colors.l, pie.colors[pie.values[[i]][1:(length(pie.values[[i]]) -
1)] >= combine.slices])
lt <- c(lt, ltext[pie.values[[i]][1:(length(pie.values[[i]]) -
1)] >= combine.slices])
}
}
if (with.legend != FALSE) {
ltext <- c(unique(lt), combined.slice.label)
pie.colors.l <- c(unique(pie.colors.l), combined.slice.color)
}
if (ncol.legend == "auto") {
if (with.legend == "bottom" || with.legend ==
"top") {
ncol.legend <- ceiling(length(pie.colors)/4)
}
else {
ncol.legend <- 1
}
}
pie.colors <- c(pie.colors, combined.slice.color)
}
else {
if (ncol.legend == "auto") {
if (with.legend == "bottom" || with.legend ==
"top") {
ncol.legend <- ceiling(ncol(x$emission_probs)/4)
}
else {
ncol.legend <- 1
}
}
}
if (!is.matrix(layout) && !is.function(layout) && (layout ==
"horizontal" || layout == "vertical")) {
do.call(igraph::plot.igraph, c(list(g1, layout = glayout,
vertex.shape = "pie", vertex.pie = pie.values,
vertex.pie.color = list(pie.colors), vertex.size = vertex.size,
vertex.label = vertex.label, vertex.label.dist = vertex.label.dist,
vertex.label.degree = vertex.label.pos, vertex.label.family = vertex.label.family,
edge.curved = edge.curved, edge.width = edge.width,
edge.label = edge.label, edge.label.family = edge.label.family,
edge.arrow.size = edge.arrow.size, xlim = xlim,
ylim = ylim, rescale = rescale, main = main),
dots))
}
else {
do.call(igraph::plot.igraph, c(list(g1, layout = glayout,
vertex.shape = "pie", vertex.pie = pie.values,
vertex.pie.color = list(pie.colors), vertex.size = vertex.size,
vertex.label = vertex.label, vertex.label.dist = vertex.label.dist,
vertex.label.degree = vertex.label.pos, vertex.label.family = vertex.label.family,
edge.curved = edge.curved, edge.width = edge.width,
edge.label = edge.label, edge.label.family = edge.label.family,
edge.arrow.size = edge.arrow.size, main = main),
dots))
}
}
else {
if (!is.matrix(layout) && !is.function(layout) && (layout ==
"horizontal" || layout == "vertical")) {
do.call(igraph::plot.igraph, c(list(g1, layout = glayout,
vertex.size = vertex.size, vertex.label = vertex.label,
vertex.label.dist = vertex.label.dist, vertex.label.degree = vertex.label.pos,
vertex.label.family = vertex.label.family, edge.curved = edge.curved,
edge.width = edge.width, edge.label = edge.label,
edge.label.family = edge.label.family, edge.arrow.size = edge.arrow.size,
xlim = xlim, ylim = ylim, rescale = rescale,
main = main), dots))
}
else {
do.call(igraph::plot.igraph, c(list(g1, layout = glayout,
vertex.size = vertex.size, vertex.label = vertex.label,
vertex.label.dist = vertex.label.dist, vertex.label.degree = vertex.label.pos,
vertex.label.family = vertex.label.family, edge.curved = edge.curved,
edge.width = edge.width, edge.label = edge.label,
edge.label.family = edge.label.family, edge.arrow.size = edge.arrow.size,
main = main), dots))
}
}
if (with.legend != FALSE && pie == TRUE) {
if (legend.order) {
seqlegend(x$observations, cpal = pie.colors.l, ltext = ltext,
position = "center", cex = cex.legend, ncol = ncol.legend,
with.missing = FALSE)
}
else {
seqlegend(x$observations, cpal = cpal.legend, ltext = ltext.orig,
position = "center", cex = cex.legend, ncol = ncol.legend,
with.missing = FALSE)
}
}
# par(mfrow = c(1, 1))
}
Now it works.
layout(matrix(c(1, 2, 3, 4), ncol=2, byrow=TRUE))
# layout.show(4)
par(cex=0.65, mar=c(2.5, 4.1, 2.5, 1.5))
seqplot(biofam.seq, type='d', with.legend=FALSE, bordplot_hmmer=NA, ylab=NA)
seqplot(biofam.seq, type='d', with.legend=FALSE, border=NA, ylab=NA)
par(cex=0.5, mar=c(1.5, 3.5, 3.5, 1.5))
plot_hmm(biofam.hmm, with.legend=FALSE, vertex.size=15)
plot_hmm(biofam.hmm, with.legend=FALSE, vertex.size=15)

Related

How do you add weights to a boxplot with ggplot2?

I´m working on a project that involves analysing the income of those who belong to the active population on a certain territorial area (an Autonomous Community). I need to create a histogram with the sample weights given to me and ggplot2. However,when I try to implement the argument "weight" to the aesthetics, it doesn´t work because whether I include the argument "weight" or not, it plots the same graph. Apart from that, I don´t know how to add the weighted mean since my graph doesn´t even take into account the weights of the sample
This is the code to generate all the data from the territorial area:
rm(list=ls(all=TRUE))
if (!require(sae)) install.packages("sae")
library(sae)
data(incomedata)
help("incomedata")
set.seed(100452840)
cual = sample(1:17,1)
(cual)
datosECV=incomedata
datosECVmas16 = subset(datosECV, (datosECV$labor>0))
datosECVmas16$age = datosECVmas16$age - 1
nrows = dim(datosECVmas16)[[1]]
datosECVmas16$horas = round(rnorm(nrows,34,3), 1)
datosECVmas16$horas[(datosECVmas16$labor==2) | (datosECVmas16$labor == 3)] = 0
datosECVmas16$income = round(jitter(datosECVmas16$income),1)
datosECVmas16$income[datosECVmas16$labor==2] = datosECVmas16$income[datosECVmas16$labor==2]*0.7
datosECVmas16$income[datosECVmas16$labor==3] = 0
datosFinal =
data.frame(ca=datosECVmas16$ac, prov=datosECVmas16$prov,
provlab=datosECVmas16$provlab, gen=datosECVmas16$gen,
edad=datosECVmas16$age, nac=datosECVmas16$nat,
neduc=datosECVmas16$educ, sitemp=datosECVmas16$labor,
ingnorm=datosECVmas16$income, horas=datosECVmas16$horas,
factorel=round(datosECVmas16$weight,1))
datos_ComValenciana = datosFinal[datosFinal[,1]==10,]
if(cual == 1) {
write.table(datos_Andalucia,"datos_Andalucia.txt",row.names=FALSE)
} else if(cual == 2) {
write.table(datos_Aragon,"datos_Aragon.txt",row.names=FALSE)
} else if(cual == 3) {
write.table(datos_Asturias,"datos_Asturias.txt",row.names=FALSE)
} else if(cual == 4) {
write.table(datos_Baleares,"datos_Baleares.txt",row.names=FALSE)
} else if(cual == 5) {
write.table(datos_Canarias,"datos_Canarias.txt",row.names=FALSE)
} else if(cual == 6) {
write.table(datos_Cantabria,"datos_Cantabria.txt",row.names=FALSE)
} else if(cual == 7) {
write.table(datos_CastillaLeon,"datos_CastillaLeon.txt",row.names=FALSE)
} else if(cual == 8) {
write.table(datos_CastillaLaMancha,"datos_CastillaLaMancha.txt",row.names=FALSE)
} else if(cual == 9) {
write.table(datos_Catalunya,"datos_Catalunya.txt",row.names=FALSE)
} else if(cual == 10) {
write.table(datos_ComValenciana,"datos_ComValenciana.txt",row.names=FALSE)
} else if(cual == 11) {
write.table(datos_Extremadura,"datos_Extremadura.txt",row.names=FALSE)
} else if(cual == 12) {
write.table(datos_Galicia,"datos_Galicia.txt",row.names=FALSE)
} else if(cual == 13) {
write.table(datos_ComMadrid,"datos_ComMadrid.txt",row.names=FALSE)
} else if(cual == 14) { write.table(datos_RegMurcia,"datos_RegMurcia.txt",row.names=FALSE)
} else if(cual == 15) {
write.table(datos_ComForalNavarra,"datos_ComForalNavarra.txt",row.names=FALSE)
} else if(cual == 16) {
write.table(datos_PaisVasco,"datos_PaisVasco.txt",row.names=FALSE)
} else {
write.table(datos_Rioja,"datos_Rioja.txt",row.names=FALSE)
}
datosFinal=datosFinal[-12086,]
datos_ComValenciana = datosFinal[datosFinal[,1]==10,]
datosFinal=datosFinal[datosFinal$sitemp<3,]
datos_ComValenciana = datosFinal[datosFinal[,1]==10,]
N <- sum(datos_ComValenciana[,"factorel"])
Important note: the weights are the ones given by the 11th column of the dataset (the dataset in this case is called datos_ComValenciana). This column is the one called "factorel". "Ingnorm" are the different incomes of different people.
This code belowe should get the job done but doesn´t:
ggplot(data = datos_ComValenciana, aes(x = ingnorm,y = ..density..,weight=factorel)) +
geom_histogram(fill="#5DC863FF",alpha=0.6,col="black",bins=18)+
xlab("Ingresos normalizados")+
ylab("Cuenta")+
scale_fill_viridis(alpha=1,discrete=TRUE, option="D")+
ggtitle("Income without the weights")`
You can directly apply any weigths in the aes() function, like this (I made a toy example with mtcars):
library(ggplot2)
library(viridis)
data("mtcars")
mtcars$wt_norm <- mtcars$wt / mean(mtcars$wt)
ggplot(data = mtcars, aes(x = mpg * wt_norm, y = after_stat(density))) +
geom_histogram(fill="#5DC863FF", alpha = 0.6, col = "black", bins = 18)+
xlab("mpg normalizado")+
ylab("Cuenta")+
scale_fill_viridis(alpha = 1, discrete = TRUE, option = "D") +
ggtitle("Consumo normalizado por peso")
Which yields a different result than:
ggplot(data = mtcars, aes(x = mpg, y = after_stat(density))) +
geom_histogram(fill="#5DC863FF", alpha = 0.6, col = "black", bins = 18)+
xlab("mpg")+
ylab("Cuenta")+
scale_fill_viridis(alpha = 1, discrete = TRUE, option = "D") +
ggtitle("Consumo")
I'm by no means an specialist in ggplot, but the argument weights, if it is valid, it seems not to be working.

How to change the position of the zoomed area from facet_zoom()?

With facet_zoom() from the ggforce package one can create nice zooms to highlight certain regions of a plot. Unfortunately, when zooming in on the y axis the original plot is always on the right side.
Is there a way to place the original plot on the left?
This would feel more intuitive to first look at the main plot and then at the zoomed region. As an example I would like to swap the position of the two facets in this plot:
(No reproducible example added, since I believe this is a question about the existence of a certain functionality.)
I've tweaked the current code for FacetZoom on GitHub to swop the horizontal order from [zoom, original] to [original, zoom]. The changes aren't complicated, but they are scattered throughout draw_panels() function's code, so the full code is rather long.
Result:
# example 1, with split = FALSE, horizontal = TRUE (i.e. default settings)
p1 <- ggplot(mtcars, aes(x = mpg, y = disp, colour = factor(cyl))) +
geom_point() +
theme_bw()
p1 + ggtitle("Original") + facet_zoom(y = disp > 300)
p1 + ggtitle("Modified") + facet_zoom2(y = disp > 300)
# example 2, with split = TRUE
p2 <- ggplot(iris, aes(Petal.Length, Petal.Width, colour = Species)) +
geom_point() +
theme_bw()
p2 + ggtitle("Original") +
facet_zoom(xy = Species == "versicolor", split = TRUE)
p2 + ggtitle("Modified") +
facet_zoom2(xy = Species == "versicolor", split = TRUE)
Code used (I've commented out the original code, where modified code is used, & indicated the packages for functions from other packages):
library(ggplot)
library(ggforce)
library(grid)
# define facet_zoom2 function to use FacetZoom2 instead of FacetZoom
# (everything else is the same as facet_zoom)
facet_zoom2 <- function(x, y, xy, zoom.data, xlim = NULL, ylim = NULL,
split = FALSE, horizontal = TRUE, zoom.size = 2,
show.area = TRUE, shrink = TRUE) {
x <- if (missing(x)) if (missing(xy)) NULL else lazyeval::lazy(xy) else lazyeval::lazy(x)
y <- if (missing(y)) if (missing(xy)) NULL else lazyeval::lazy(xy) else lazyeval::lazy(y)
zoom.data <- if (missing(zoom.data)) NULL else lazyeval::lazy(zoom.data)
if (is.null(x) && is.null(y) && is.null(xlim) && is.null(ylim)) {
stop("Either x- or y-zoom must be given", call. = FALSE)
}
if (!is.null(xlim)) x <- NULL
if (!is.null(ylim)) y <- NULL
ggproto(NULL, FacetZoom2,
shrink = shrink,
params = list(
x = x, y = y, xlim = xlim, ylim = ylim, split = split, zoom.data = zoom.data,
zoom.size = zoom.size, show.area = show.area,
horizontal = horizontal
)
)
}
# define FacetZoom as a ggproto object that inherits from FacetZoom,
# with a modified draw_panels function. the compute_layout function references
# the version currently on GH, which is slightly different from the CRAN
# package version.
FacetZoom2 <- ggproto(
"FacetZoom2",
ggforce::FacetZoom,
compute_layout = function(data, params) {
layout <- rbind( # has both x & y dimension
data.frame(name = 'orig', SCALE_X = 1L, SCALE_Y = 1L),
data.frame(name = 'x', SCALE_X = 2L, SCALE_Y = 1L),
data.frame(name = 'y', SCALE_X = 1L, SCALE_Y = 2L),
data.frame(name = 'full', SCALE_X = 2L, SCALE_Y = 2L),
data.frame(name = 'orig_true', SCALE_X = 1L, SCALE_Y = 1L),
data.frame(name = 'zoom_true', SCALE_X = 1L, SCALE_Y = 1L)
)
if (is.null(params$y) && is.null(params$ylim)) { # no y dimension
layout <- layout[c(1,2, 5:6),]
} else if (is.null(params$x) && is.null(params$xlim)) { # no x dimension
layout <- layout[c(1,3, 5:6),]
}
layout$PANEL <- seq_len(nrow(layout))
layout
},
draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord,
data, theme, params) {
if (is.null(params$x) && is.null(params$xlim)) {
params$horizontal <- TRUE
} else if (is.null(params$y) && is.null(params$ylim)) {
params$horizontal <- FALSE
}
if (is.null(theme[['zoom']])) {
theme$zoom <- theme$strip.background
}
if (is.null(theme$zoom.x)) {
theme$zoom.x <- theme$zoom
}
if (is.null(theme$zoom.y)) {
theme$zoom.y <- theme$zoom
}
axes <- render_axes(ranges, ranges, coord, theme, FALSE)
panelGrobs <- ggforce:::create_panels(panels, axes$x, axes$y)
panelGrobs <- panelGrobs[seq_len(length(panelGrobs) - 2)]
if ('full' %in% layout$name && !params$split) {
panelGrobs <- panelGrobs[c(1, 4)]
}
# changed coordinates in indicator / lines to zoom from
# the opposite horizontal direction
if ('y' %in% layout$name) {
if (!inherits(theme$zoom.y, 'element_blank')) {
zoom_prop <- scales::rescale(
y_scales[[2]]$dimension(ggforce:::expansion(y_scales[[2]])),
from = y_scales[[1]]$dimension(ggforce:::expansion(y_scales[[1]])))
indicator <- polygonGrob(
x = c(0, 0, 1, 1), # was x = c(1, 1, 0, 0),
y = c(zoom_prop, 1, 0),
gp = gpar(col = NA, fill = alpha(theme$zoom.y$fill, 0.5)))
lines <- segmentsGrob(
x0 = c(1, 1), x1 = c(0, 0), # was x0 = c(0, 0), x1 = c(1, 1)
y0 = c(0, 1), y1 = zoom_prop,
gp = gpar(col = theme$zoom.y$colour,
lty = theme$zoom.y$linetype,
lwd = theme$zoom.y$size,
lineend = 'round'))
indicator_h <- grobTree(indicator, lines)
} else {
indicator_h <- zeroGrob()
}
}
if ('x' %in% layout$name) {
if (!inherits(theme$zoom.x, 'element_blank')) {
zoom_prop <- scales::rescale(x_scales[[2]]$dimension(ggforce:::expansion(x_scales[[2]])),
from = x_scales[[1]]$dimension(ggforce:::expansion(x_scales[[1]])))
indicator <- polygonGrob(c(zoom_prop, 1, 0), c(1, 1, 0, 0),
gp = gpar(col = NA, fill = alpha(theme$zoom.x$fill, 0.5)))
lines <- segmentsGrob(x0 = c(0, 1), y0 = c(0, 0), x1 = zoom_prop, y1 = c(1, 1),
gp = gpar(col = theme$zoom.x$colour,
lty = theme$zoom.x$linetype,
lwd = theme$zoom.x$size,
lineend = 'round'))
indicator_v <- grobTree(indicator, lines)
} else {
indicator_v <- zeroGrob()
}
}
if ('full' %in% layout$name && params$split) {
space.x <- theme$panel.spacing.x
if (is.null(space.x)) space.x <- theme$panel.spacing
space.x <- unit(5 * as.numeric(convertUnit(space.x, 'cm')), 'cm')
space.y <- theme$panel.spacing.y
if (is.null(space.y)) space.y <- theme$panel.spacing
space.y <- unit(5 * as.numeric(convertUnit(space.y, 'cm')), 'cm')
# change horizontal order of panels from [zoom, original] to [original, zoom]
# final <- gtable::gtable_add_cols(panelGrobs[[3]], space.x)
# final <- cbind(final, panelGrobs[[1]], size = 'first')
# final_tmp <- gtable::gtable_add_cols(panelGrobs[[4]], space.x)
# final_tmp <- cbind(final_tmp, panelGrobs[[2]], size = 'first')
final <- gtable::gtable_add_cols(panelGrobs[[1]], space.x)
final <- cbind(final, panelGrobs[[3]], size = 'first')
final_tmp <- gtable::gtable_add_cols(panelGrobs[[2]], space.x)
final_tmp <- cbind(final_tmp, panelGrobs[[4]], size = 'first')
final <- gtable::gtable_add_rows(final, space.y)
final <- rbind(final, final_tmp, size = 'first')
final <- gtable::gtable_add_grob(final, list(indicator_h, indicator_h),
c(2, 6), 3, c(2, 6), 5,
z = -Inf, name = "zoom-indicator")
final <- gtable::gtable_add_grob(final, list(indicator_v, indicator_v),
3, c(2, 6), 5,
z = -Inf, name = "zoom-indicator")
heights <- unit.c(
unit(max_height(list(axes$x[[1]]$top, axes$x[[3]]$top)), 'cm'),
unit(1, 'null'),
unit(max_height(list(axes$x[[1]]$bottom, axes$x[[3]]$bottom)), 'cm'),
space.y,
unit(max_height(list(axes$x[[2]]$top, axes$x[[4]]$top)), 'cm'),
unit(params$zoom.size, 'null'),
unit(max_height(list(axes$x[[2]]$bottom, axes$x[[4]]$bottom)), 'cm')
)
# swop panel width specifications according to the new horizontal order
widths <- unit.c(
# unit(max_width(list(axes$y[[3]]$left, axes$y[[4]]$left)), 'cm'),
# unit(params$zoom.size, 'null'),
# unit(max_height(list(axes$y[[3]]$right, axes$y[[4]]$right)), 'cm'),
# space.x,
# unit(max_width(list(axes$y[[1]]$left, axes$y[[2]]$left)), 'cm'),
# unit(1, 'null'),
# unit(max_height(list(axes$y[[1]]$right, axes$y[[2]]$right)), 'cm')
unit(max_width(list(axes$y[[1]]$left, axes$y[[2]]$left)), 'cm'),
unit(1, 'null'),
unit(max_height(list(axes$y[[1]]$right, axes$y[[2]]$right)), 'cm'),
space.x,
unit(max_width(list(axes$y[[3]]$left, axes$y[[4]]$left)), 'cm'),
unit(params$zoom.size, 'null'),
unit(max_height(list(axes$y[[3]]$right, axes$y[[4]]$right)), 'cm')
)
final$heights <- heights
final$widths <- widths
} else {
if (params$horizontal) {
space <- theme$panel.spacing.x
if (is.null(space)) space <- theme$panel.spacing
space <- unit(5 * as.numeric(convertUnit(space, 'cm')), 'cm')
heights <- unit.c(
unit(max_height(list(axes$x[[1]]$top, axes$x[[2]]$top)), 'cm'),
unit(1, 'null'),
unit(max_height(list(axes$x[[1]]$bottom, axes$x[[2]]$bottom)), 'cm')
)
# change horizontal order of panels from [zoom, original] to [original, zoom]
# first <- gtable::gtable_add_cols(panelGrobs[[2]], space)
# first <- cbind(final, panelGrobs[[1]], size = 'first')
final <- gtable::gtable_add_cols(panelGrobs[[1]], space)
final <- cbind(final, panelGrobs[[2]], size = "first")
final$heights <- heights
# swop panel width specifications according to the new horizontal order
# unit(c(params$zoom.size, 1), 'null')
final$widths[panel_cols(final)$l] <- unit(c(1, params$zoom.size), 'null')
final <- gtable::gtable_add_grob(final, indicator_h, 2, 3, 2, 5,
z = -Inf, name = "zoom-indicator")
} else {
space <- theme$panel.spacing.y
if (is.null(space)) space <- theme$panel.spacing
space <- unit(5 * as.numeric(convertUnit(space, 'cm')), 'cm')
widths <- unit.c(
unit(max_width(list(axes$y[[1]]$left, axes$y[[2]]$left)), 'cm'),
unit(1, 'null'),
unit(max_height(list(axes$y[[1]]$right, axes$y[[2]]$right)), 'cm')
)
final <- gtable::gtable_add_rows(panelGrobs[[1]], space)
final <- rbind(final, panelGrobs[[2]], size = 'first')
final$widths <- widths
final$heights[panel_rows(final)$t] <- unit(c(1, params$zoom.size), 'null')
final <- gtable::gtable_add_grob(final, indicator_v, 3, 2, 5,
z = -Inf, name = "zoom-indicator")
}
}
final
}
)
Note: create_panels and expansion are un-exported functions from the ggforce package, so I referenced them with triple colons. This isn't robust for writing packages, but should suffice as a temporary workaround.
Update 30 Oct 2019: A suggestion for those seeing errors like Invalid 'type' (list) of argument after trying to use this solution as-is. The issue is likely due to updates made to the ggforcepackage since this solution was developed. To get the code in this solution working again, install the version of ggforce that was available when the solution was developed. This can be done with the devtools package pointing to the 4008a2e commit:
devtools::install_github("thomasp85/ggforce", ref = '4008a2e')

biwavelet package: "cex.axis" not working in plot.biwavelet(); A bug?

I am using biwavelet package to conduct wavelet analysis. However, when I want to adjust the label size for axis using cex.axis, the label size does not changed. On the other hand, cex.lab and cex.main are working well. Is this a bug? The following gives a reproducible example.
library(biwavelet)
t1 <- cbind(1:100, rnorm(100))
t2 <- cbind(1:100, rnorm(100))
# Continuous wavelet transform
wt.t1 <- wt(t1)
par(oma = c(0, 0.5, 0, 0), mar = c(4, 2, 2, 4))
plot(wt.t1,plot.cb = T,plot.phase = T,type = 'power.norm',
xlab = 'Time(year)',ylab = 'Period(year)',mgp=c(2,1,0),
main='Winter station 1',cex.main=0.8,cex.lab=0.8,cex.axis=0.8)
Edit
There was a previous question on this site a month ago: Wavelets plot: changing x-, y- axis, and color plot, but not solved. Any help this time? Thank you!
Yeah, it is a bug. Here is patched version: my.plot.biwavelet()
This version accepts argument cex.axis (defaults to 1), and you can change it when needed. I will briefly explain to you what the problem is, in the "explanation" section in the end.
my.plot.biwavelet <- function (x, ncol = 64, fill.cols = NULL, xlab = "Time", ylab = "Period",
tol = 1, plot.cb = FALSE, plot.phase = FALSE, type = "power.corr.norm",
plot.coi = TRUE, lwd.coi = 1, col.coi = "white", lty.coi = 1,
alpha.coi = 0.5, plot.sig = TRUE, lwd.sig = 4, col.sig = "black",
lty.sig = 1, bw = FALSE, legend.loc = NULL, legend.horiz = FALSE,
arrow.len = min(par()$pin[2]/30, par()$pin[1]/40), arrow.lwd = arrow.len *
0.3, arrow.cutoff = 0.9, arrow.col = "black", xlim = NULL,
ylim = NULL, zlim = NULL, xaxt = "s", yaxt = "s", form = "%Y", cex.axis = 1,
...) {
if (is.null(fill.cols)) {
if (bw) {
fill.cols <- c("black", "white")
}
else {
fill.cols <- c("#00007F", "blue", "#007FFF",
"cyan", "#7FFF7F", "yellow", "#FF7F00", "red",
"#7F0000")
}
}
col.pal <- colorRampPalette(fill.cols)
fill.colors <- col.pal(ncol)
types <- c("power.corr.norm", "power.corr", "power.norm",
"power", "wavelet", "phase")
type <- match.arg(tolower(type), types)
if (type == "power.corr" | type == "power.corr.norm") {
if (x$type == "wtc" | x$type == "xwt") {
x$power <- x$power.corr
x$wave <- x$wave.corr
}
else {
x$power <- x$power.corr
}
}
if (type == "power.norm" | type == "power.corr.norm") {
if (x$type == "xwt") {
zvals <- log2(x$power)/(x$d1.sigma * x$d2.sigma)
if (is.null(zlim)) {
zlim <- range(c(-1, 1) * max(zvals))
}
zvals[zvals < zlim[1]] <- zlim[1]
locs <- pretty(range(zlim), n = 5)
leg.lab <- 2^locs
}
else if (x$type == "wtc" | x$type == "pwtc") {
zvals <- x$rsq
zvals[!is.finite(zvals)] <- NA
if (is.null(zlim)) {
zlim <- range(zvals, na.rm = TRUE)
}
zvals[zvals < zlim[1]] <- zlim[1]
locs <- pretty(range(zlim), n = 5)
leg.lab <- locs
}
else {
zvals <- log2(abs(x$power/x$sigma2))
if (is.null(zlim)) {
zlim <- range(c(-1, 1) * max(zvals))
}
zvals[zvals < zlim[1]] <- zlim[1]
locs <- pretty(range(zlim), n = 5)
leg.lab <- 2^locs
}
}
else if (type == "power" | type == "power.corr") {
zvals <- log2(x$power)
if (is.null(zlim)) {
zlim <- range(c(-1, 1) * max(zvals))
}
zvals[zvals < zlim[1]] <- zlim[1]
locs <- pretty(range(zlim), n = 5)
leg.lab <- 2^locs
}
else if (type == "wavelet") {
zvals <- (Re(x$wave))
if (is.null(zlim)) {
zlim <- range(zvals)
}
locs <- pretty(range(zlim), n = 5)
leg.lab <- locs
}
else if (type == "phase") {
zvals <- x$phase
if (is.null(zlim)) {
zlim <- c(-pi, pi)
}
locs <- pretty(range(zlim), n = 5)
leg.lab <- locs
}
if (is.null(xlim)) {
xlim <- range(x$t)
}
yvals <- log2(x$period)
if (is.null(ylim)) {
ylim <- range(yvals)
}
else {
ylim <- log2(ylim)
}
image(x$t, yvals, t(zvals), zlim = zlim, xlim = xlim,
ylim = rev(ylim), xlab = xlab, ylab = ylab, yaxt = "n",
xaxt = "n", col = fill.colors, ...)
box()
if (class(x$xaxis)[1] == "Date" | class(x$xaxis)[1] ==
"POSIXct") {
if (xaxt != "n") {
xlocs <- pretty(x$t) + 1
axis(side = 1, at = xlocs, labels = format(x$xaxis[xlocs],
form))
}
}
else {
if (xaxt != "n") {
xlocs <- axTicks(1)
axis(side = 1, at = xlocs, cex.axis = cex.axis)
}
}
if (yaxt != "n") {
axis.locs <- axTicks(2)
yticklab <- format(2^axis.locs, dig = 1)
axis(2, at = axis.locs, labels = yticklab, cex.axis = cex.axis)
}
if (plot.coi) {
polygon(x = c(x$t, rev(x$t)), lty = lty.coi, lwd = lwd.coi,
y = c(log2(x$coi), rep(max(log2(x$coi), na.rm = TRUE),
length(x$coi))), col = adjustcolor(col.coi,
alpha.f = alpha.coi), border = col.coi)
}
if (plot.sig & length(x$signif) > 1) {
if (x$type %in% c("wt", "xwt")) {
contour(x$t, yvals, t(x$signif), level = tol,
col = col.sig, lwd = lwd.sig, add = TRUE, drawlabels = FALSE)
}
else {
tmp <- x$rsq/x$signif
contour(x$t, yvals, t(tmp), level = tol, col = col.sig,
lwd = lwd.sig, add = TRUE, drawlabels = FALSE)
}
}
if (plot.phase) {
a <- x$phase
locs.phases <- which(zvals < quantile(zvals, arrow.cutoff))
a[locs.phases] <- NA
phase.plot(x$t, log2(x$period), a, arrow.len = arrow.len,
arrow.lwd = arrow.lwd, arrow.col = arrow.col)
}
box()
if (plot.cb) {
fields::image.plot(x$t, yvals, t(zvals), zlim = zlim, ylim = rev(range(yvals)),
xlab = xlab, ylab = ylab, col = fill.colors,
smallplot = legend.loc, horizontal = legend.horiz,
legend.only = TRUE, axis.args = list(at = locs,
labels = format(leg.lab, dig = 2)), xpd = NA)
}
}
Test
library(biwavelet)
t1 <- cbind(1:100, rnorm(100))
t2 <- cbind(1:100, rnorm(100))
# Continuous wavelet transform
wt.t1 <- wt(t1)
par(oma = c(0, 0.5, 0, 0), mar = c(4, 2, 2, 4))
my.plot.biwavelet(wt.t1,plot.cb = T,plot.phase = T,type = 'power.norm',
xlab = 'Time(year)',ylab = 'Period(year)',mgp=c(2,1,0),
main='Winter station 1',cex.main=0.8,cex.lab=0.8,cex.axis=0.8)
As expected, it is working.
Explanation
In plot.biwavelet(), why passing cex.axis via ... does not work?
plot.biwavelet() generates the your final plot mainly in 3 stages:
image(..., xaxt = "n", yaxt = "n") for generating basic plot;
axis(1, at = atTicks(1)); axis(2, at = atTicks(2)) for adding axis;
fields::image.plot() for displaying colour legend strip.
Now, although this function takes ..., they are only fed to the first image() call, while the following axis(), (including polygon(), contour(), phase.plot()) and image.plot() take none from .... When later calling axis(), no flexible specification with respect to axis control are supported.
I guess during package development time, problem described as in: Giving arguments from “…” argument to right function in R had been encountered. Maybe the author did not realize this potential issue, leaving a bug here. My answer to that post, as well as Roland's comments, points toward a robust fix.
I am not the package author so can not decide how he will fix this. My fix is brutal, but works for you temporary need: just add the cex.axis argument to axis() call. I have reached Tarik (package author) with an email, and I believe he will give you a much better explanation and solution.
I fixed this issue by passing the ... argument to axis in plot.biwavelet. Your code should now work as desired. Note that changes to cex.axis and other axis arguments will affect all three axes (x, y, z).
You can download the new version (0.20.8) of biwavelet from GitHub by issuing the following command at the R console (this assumes that you have the package devtools already installed): devtools::install_github("tgouhier/biwavelet")
Thanks for pointing out the bug!

How can I add text to a network plot in R?

I am using the package networkDynamic to visualise two evolving networks and I would like to add, close to each network a simple legend (a few words of text). I can't find a way of doing this.
In the networkDynamic package, the function render.animation uses plot.network (from the package network) to render each frame and then compiles the different frames into an animation.
The plot.network arguments can be passed to render.animation, so the problem seems to boils down to adding text to a plot generated with plot.network but there doesn't seem to be a way of adding text at specified coordinates.
With a normal plot I would use the text function, but is there a way of including this function into the plot.network arguments?
render.animation is a function in the ndtv package. You will have to create a custom render.animation2 function based on render.animation. In the following function, I add an extra line to the render.animation function. I add an mtext after each plot.network calls (see about 20 lines from the end). You could change it to a text instead of mtext.
render.animation2 <- function (net, render.par = list(tween.frames = 10, show.time = TRUE,
show.stats = NULL, extraPlotCmds = NULL, initial.coords = 0),
plot.par = list(bg = "white"), ani.options = list(interval = 0.1),
render.cache = c("plot.list", "none"), verbose = TRUE, ...)
{
if (!is.network(net)) {
stop("render.animation requires the first argument to be a network object")
}
if (is.null(render.par)) {
stop("render.animation is missing the 'render.par' argument (a list of rendering parameters).")
}
if (is.null(render.par$tween.frames)) {
render.par$tween.frames <- 10
}
if (is.null(render.par$show.time)) {
render.par$show.time <- TRUE
}
if (is.null(render.par$initial.coords)) {
render.par$initial.coords <- matrix(0, ncol = 2, nrow = network.size(net))
}
if (!all(c("animation.x.active", "animation.y.active") %in%
list.vertex.attributes(net))) {
net <- compute.animation(net, verbose = verbose)
}
externalDevice <- FALSE
doRStudioHack <- TRUE
if (!is.null(render.par$do_RStudio_plot_hack)) {
doRStudioHack <- render.par$do_RStudio_plot_hack
}
if (!is.function(options()$device)) {
if (names(dev.cur()) == "RStudioGD" & doRStudioHack) {
message("RStudio's graphics device is not well supported by ndtv, attempting to open another type of plot window")
if (.Platform$OS.type == "windows") {
windows()
}
else if (length(grep(R.version$platform, pattern = "apple")) >
0) {
quartz()
}
else {
x11()
}
externalDevice <- TRUE
}
}
if (par("bg") == "transparent" & is.null(plot.par$bg)) {
plot.par$bg <- "white"
}
origPar <- par(plot.par)
oopts <- ani.options(ani.options)
slice.par <- get.network.attribute(net, "slice.par")
if (is.null(slice.par)) {
stop("render.animation can not locate the 'slice.par' list of parameters in the input network object")
}
render.cache <- match.arg(render.cache)
plot_params <- list(...)
if (is.null(plot_params$label)) {
plot_params$label <- function(slice) {
network.vertex.names(slice)
}
}
if (is.null(plot_params$xlab) & render.par$show.time) {
plot_params$xlab <- function(onset, terminus) {
ifelse(onset == terminus, paste("t=", onset, sep = ""),
paste("t=", onset, "-", terminus, sep = ""))
}
}
if (!is.null(render.par$show.stats) && render.par$show.stats !=
FALSE) {
if (render.par$show.time) {
plot_params$xlab <- eval(parse(text = paste("function(slice,onset,terminus){stats<-summary.statistics.network(slice",
render.par$show.stats, ")\n return(paste('t=',onset,'-',terminus,' ',paste(rbind(names(stats),stats),collapse=':'),sep='')) }",
sep = "")))
}
else {
plot_params$xlab <- eval(parse(text = paste("function(slice){stats<-summary.statistics.network(slice",
render.par$show.stats, ")\n return(paste(rbind(names(stats),stats),collapse=':')) }",
sep = "")))
}
}
if (is.null(plot_params$jitter)) {
plot_params$jitter <- FALSE
}
interp.fun <- coord.interp.smoothstep
starts <- seq(from = slice.par$start, to = slice.par$end,
by = slice.par$interval)
ends <- seq(from = slice.par$start + slice.par$aggregate.dur,
to = slice.par$end + slice.par$aggregate.dur, by = slice.par$interval)
xmin <- aggregate.vertex.attribute.active(net, "animation.x",
min)
xmax <- aggregate.vertex.attribute.active(net, "animation.x",
max)
ymin <- aggregate.vertex.attribute.active(net, "animation.y",
min)
ymax <- aggregate.vertex.attribute.active(net, "animation.y",
max)
if (is.null(plot_params$xlim)) {
if (xmin == xmax) {
xmax <- xmin + 1
xmin <- xmin - 1
}
plot_params$xlim <- c(xmin, xmax)
}
if (is.null(plot_params$ylim)) {
if (ymin == ymax) {
ymax <- ymin + 1
ymin <- ymin - 1
}
plot_params$ylim <- c(ymin, ymax)
}
if (is.numeric(render.par$initial.coords)) {
coords <- matrix(render.par$initial.coords, ncol = 2,
nrow = network.size(net))
}
slice <- network.collapse(net, starts[1], ends[1], rule = slice.par$rule,
rm.time.info = FALSE)
activev <- is.active(net, starts[1], ends[1], v = seq_len(network.size(net)),
rule = if (slice.par$rule != "all") {
"any"
})
if (length(slice) > 0 & network.size(slice) > 0) {
coords[activev, 1] <- get.vertex.attribute(slice, "animation.x")
coords[activev, 2] <- get.vertex.attribute(slice, "animation.y")
}
coords2 <- coords
if (render.cache == "plot.list") {
ani.record(reset = TRUE)
}
for (s in 1:length(starts)) {
if (verbose) {
print(paste("rendering", render.par$tween.frames,
"frames for slice", s - 1))
}
slice <- network.collapse(net, starts[s], ends[s], rule = slice.par$rule,
rm.time.info = FALSE)
activev <- is.active(net, starts[s], ends[s], v = seq_len(network.size(net)),
rule = if (slice.par$rule != "all") {
"any"
})
if (length(slice) > 0 & network.size(slice) > 0) {
evald_params <- .evaluate_plot_params(plot_params = plot_params,
net = net, slice = slice, s = s, onset = starts[s],
terminus = ends[s])
for (t in 1:render.par$tween.frames) {
coords2[activev, 1] <- get.vertex.attribute(slice,
"animation.x")
coords2[activev, 2] <- get.vertex.attribute(slice,
"animation.y")
tweenCoords <- interp.fun(coords, coords2, t,
render.par$tween.frames)
plot_args <- list(x = slice, coord = tweenCoords[activev,
, drop = FALSE])
plot_args <- c(plot_args, evald_params)
do.call(plot.network, plot_args)
mtext("my text\n on two lines", side = 3) #my.legend
if (!is.null(render.par$extraPlotCmds)) {
eval(render.par$extraPlotCmds)
}
if (render.cache == "plot.list") {
ani.record()
}
}
coords <- coords2
}
else {
evald_params <- .evaluate_plot_params(plot_params = plot_params,
net = net, slice = slice, s = s, onset = starts[s],
terminus = ends[s])
if (render.par$show.time) {
xlab <- evald_params$xlab
}
else {
xlab <- NULL
}
singlenet <- network.initialize(1)
for (t in 1:render.par$tween.frames) {
plot.network(singlenet, vertex.cex = 0, xlab = xlab)
if (!is.null(render.par$extraPlotCmds)) {
eval(render.par$extraPlotCmds)
}
if (render.cache == "plot.list") {
ani.record()
}
}
}
}
par(origPar)
if (externalDevice) {
dev.off()
}
}
It is then important to assign your new function render.animation2 to the ndtv namespace. If you don't, it will crash because render.animation refers to functions that can only be found in its own namespace.
environment(render.animation2) <- asNamespace('ndtv')
environment(render.animation) #<environment: namespace:ndtv>
environment(render.animation2) #<environment: namespace:ndtv>
Using, render.animation2, you will then get your legend printed on each slide of the animation.
require(ndtv)
triangle <- network.initialize(3) # create a toy network
add.edge(triangle,1,2)
# add an edge between vertices 1 and 2
add.edge(triangle,2,3)
# add a more edges
activate.edges(triangle,at=1) # turn on all edges at time 1 only
activate.edges(triangle,onset=2, terminus=3,
e=get.edgeIDs(triangle,v=1,alter=2))
add.edges.active(triangle,onset=4, length=2,tail=3,head=1)
render.animation2(triangle) #custom function
ani.replay()
Here's what the last slide looks like in the animation:
If you only need to add a few lines of text, you can pass the standard plot arguments main (for the main title) or xlab (for the x-axis caption). you can separate lines with the newline escape "\n"
library(ndtv)
data(short.stergm.sim)
render.animation(short.stergm.sim,main='hello\nworld')
It is also possible to plot other graphic elements (such as legend or text or maps) using the extraPlotCmds argument to render.animation. For example, if you wanted to plot "hello world" in blue at coordiantes 0,0 using text you can wrap it in an expression and pass it in via render.par
render.animation(short.stergm.sim,
render.par=list(extraPlotCmds=expression(
text(0,0,'hello\nworld',col='blue')
))
)
the extra plot command will evaluated on each frame as the network is rendered

Major and minor axis ticks for dates in base R

I want to create major and minor ticks in my date-formatted x-axis, so that for every 3rd tick (representing every 3 months) I have a major tick and a label.
This is a reproducible example of what I have so far, which currently has uniform ticks.
month<-c("2010-08-01", "2010-09-01", "2010-10-01", "2010-12-01", "2011-01-01", "2011-02-01",
"2011-03-01", "2011-04-01", "2011-05-01", "2011-06-01", "2011-07-01", "2011-09-01",
"2011-11-01", "2012-01-01", "2012-02-01", "2012-03-01", "2012-05-01", "2012-07-01",
"2012-08-01")
prevalence<-c(10,7.5,5.2,3.5,6.4,2.7,5.8,13.2,4.3,4.7,6.4,4.4,5.2,3.3,1.0,3.1,9.9,33.3,1.0)
df<-data.frame(month, prevalence)
df$month<-as.Date(df$month)
plot(df$month, df$prevalence,lwd = 1.8, ylim=c(0,40),pch=16, bty='n', xaxt='n',
ylab="Prevalence (%)", xlab="Month",col='black',cex=1,cex.lab=1.0,cex.axis=1.0)
at <- seq(from = min(df$month), to = max(df$month), by = "month") # produces a regular sequence of dates
axis.Date(side = 1, at = at, labels = FALSE, tck=-0.04)
axis(side=2, at=c(0,10,20,30,40,50), labels=c("", "", "", "", "", ""), tck=-0.04)
lines(df$month, df$prevalence, col='black', lwd=1.8)
I have tried using the package magicaxis, but it does not seem to allow for date-formatted axes.
As a quick fix you could use repeat axis.Date calls.
at1 <- at[c(TRUE, TRUE, FALSE)]
axis.Date(side = 1, at = at1, labels = FALSE, tck=-0.02)
at2 <- at[c(FALSE, FALSE, TRUE)]
axis.Date(side = 1, at = at2, labels = TRUE, tck=-0.04)
The TRUE and FALSE are used to subset the vector at
I don't know if this is still a problem for someone, but I made a general purpose function for axes with minor ticks, based on the base axis() function, and with similar arguments. It's available in the StratigrapheR package under minorAxis()
minorAxis <- function(side, n = NULL, at.maj = NULL, at.min = NULL, range = NULL,
tick.ratio = 0.5, labels.maj = TRUE, line = NA, pos = NA,
outer = FALSE, font = NA, lty = "solid", lwd = 1,
lwd.ticks = lwd, col = NULL, col.ticks = NULL, hadj = NA,
padj = NA, extend = FALSE, tcl = NA, ...)
{
if(side == 1 | side == 3){
tick.pos <- par("xaxp")
} else if (side == 2 | side == 4) {
tick.pos <- par("yaxp")
}
# Define the positions of major ticks ----
if(is.null(at.maj)) {
# nat.int <- (tick.pos[2] - tick.pos[1])/tick.pos[3]
at.maj <- seq(tick.pos[1], tick.pos[2],
by = (tick.pos[2] - tick.pos[1])/tick.pos[3])
}
# Define range, exclude at.maj values if necessary ----
if(length(range) != 0){
eff.range <- range
r1 <- at.maj - min(range)
r2 <- at.maj - max(range)
p1 <- which.min(abs(r1))
p2 <- which.min(abs(r2))
if(!(abs(r1[p1]/min(range)) < 1.5e-8) & r1[p1] < 0) p1 <- p1 + 1
if(!(abs(r2[p2]/max(range)) < 1.5e-8) & r2[p2] > 0) p2 <- p2 - 1
at.maj <- at.maj[p1:p2]
} else {
if(side == 1 | side == 3){
eff.range <- par("usr")[1:2]
} else if (side == 2 | side == 4) {
eff.range <- par("usr")[3:4]
}
}
# Define limits ----
if(!extend) {
if(!is.null(at.min) & length(range) == 0){
limits <- c(min(c(at.min, at.maj)), max(c(at.min, at.maj)))
} else {
limits <- c(min(at.maj), max(at.maj))
}
} else {
limits <- eff.range
}
# Standard axis when n and at.min are not given ----
if(is.null(n) & is.null(at.min)){
axis(side, at = limits, labels = FALSE, tick = TRUE, line = line,
pos = pos, outer = outer, lty = lty, lwd = lwd, lwd.ticks = 0,
col = col,...)
axis(side, at = at.maj, labels = labels.maj, tick = TRUE, line = line,
pos = pos, outer = outer, font = font, lty = lty,
lwd = 0, lwd.ticks = lwd.ticks, col = col, col.ticks = col.ticks,
hadj = hadj, padj = padj, tcl = tcl,...)
} else {
# Work the minor ticks: check regularity ----
mina <- min(at.maj)
maxa <- max(at.maj)
difa <- maxa - mina
na <- difa / (length(at.maj) - 1)
if(is.null(at.min))
{
# n realm ----
# Checks----
sia <- seq(mina,maxa,by = na)
if(!isTRUE(all.equal(sort(sia),sort(at.maj)))) {
stop("at.maj is irregular, use at.min for minor ticks (not n)")
}
if(!(is.numeric(n) & length(n) == 1)){
stop("n should be a numeric of length one")
}
# Work it ----
tick.pos <- c(mina,maxa,difa/na)
nat.int <- (tick.pos[2] - tick.pos[1])/tick.pos[3]
# Define the position of minor ticks ----
distance.between.minor <- nat.int/n
p <- seq(min(at.maj), max(at.maj), by = distance.between.minor)
q <- sort(every_nth(p,n,empty=FALSE))
# Extend outside of major ticks range if necessary ----
if(!extend) {
tick.seq <- q
} else {
possible.low.minors <- min(at.maj) - (n:1) * distance.between.minor
possible.hi.minors <- max(at.maj) + (1:n) * distance.between.minor
r3 <- possible.low.minors - min(eff.range)
r4 <- possible.hi.minors - max(eff.range)
p3 <- which.min(abs(r3))
p4 <- which.min(abs(r4))
if(!(abs(r3[p3]/min(eff.range)) < 1.5e-8) & r3[p3] < 0) p3 <- p3 + 1
if(!(abs(r4[p4]/max(eff.range)) < 1.5e-8) & r4[p4] > 0) p4 <- p4 - 1
if(p3 < length(possible.low.minors + 1)){
low.candidates <- seq(p3, length(possible.low.minors), 1)
low.laureates <- possible.low.minors[low.candidates]
} else {
low.laureates <- NULL
}
if(p4 > 0){
hi.candidates <- seq(1, p4, 1)
hi.laureates <- possible.hi.minors[ hi.candidates]
} else {
hi.laureates <- NULL
}
tick.seq <- c(low.laureates,q,hi.laureates)
}
} else {
# at.min realm ----
tick.pos <- c(mina,maxa,na)
tick.seq <- sort(at.min)
if(length(range) != 0){
r3 <- tick.seq - min(eff.range)
r4 <- tick.seq - max(eff.range)
p3 <- which.min(abs(r3))
p4 <- which.min(abs(r4))
if(!(abs(r3[p3]/min(eff.range)) < 1.5e-8) & r3[p3] < 0) p3 <- p3 + 1
if(!(abs(r4[p4]/max(eff.range)) < 1.5e-8) & r4[p4] > 0) p4 <- p4 - 1
tick.seq <- tick.seq [p3:p4]
}
}
# Define the length of ticks ----
if(is.na(tcl)) maj.tcl <- par()$tcl else if (!is.na(tcl)) maj.tcl <- tcl
min.tcl <- maj.tcl*tick.ratio
# Plot the axes ----
axis(side, at = limits, labels = FALSE, tick = TRUE, line = line,
pos = pos, outer = outer, lty = lty, lwd = lwd, lwd.ticks = 0,
col = col,...)
axis(side, at = at.maj, labels = labels.maj, tick = TRUE, line = line,
pos = pos, outer = outer, font = font, lty = lty,
lwd = 0, lwd.ticks = lwd.ticks, col = col, col.ticks = col.ticks,
hadj = hadj, padj = padj, tcl = maj.tcl,...)
axis(side, at = tick.seq, labels = FALSE, tick = TRUE, line = line,
pos = pos, outer = outer, lwd = 0, lwd.ticks = lwd.ticks, col = col,
col.ticks = col.ticks, tcl = min.tcl,...)
}
}
# Run this as example:
plot(c(0,1), c(0,1), axes = FALSE, type = "n", xlab = "", ylab = "")
minorAxis(1, n = 10, range = c(0.12,0.61))
minorAxis(3, n = 10, extend=FALSE)

Resources