Related
I use this example
library(alluvial)
tit <- as.data.frame(Titanic)
# only two variables: class and survival status
tit2d <- aggregate( Freq ~ Class + Survived, data=tit, sum)
alluvial( tit2d[,1:2], freq=tit2d$Freq, xw=0.0, alpha=0.8,
gap.width=0.1, col= "steelblue", border="white",
layer = tit2d$Survived != "Yes" , cex.axis =8)
Pay attention I use cex.axis =8 and i get
Axis labels go beyond
I try to use par(mar=c(10, 10, 10, 10)) but no result
thanks for any idea
There is a bug in the source code of the alluvial function
The function sets par(mar=c(2,1,1,1)) hard coded so using the par() outside doesn't have any effect.
You could change locally the source code of the function to one of 2 options:
add an argument mar_ and pass the margin, and set at the right place par(mar=mar_).
just overwrite locally the line to the desired margins
I found the first option more appealing because you can then set the values from outside the function and optimise more easily.
The source code:
function (..., freq, col = "gray", border = 0, layer, hide = FALSE,
alpha = 0.5, gap.width = 0.05, xw = 0.1, cw = 0.1, blocks = TRUE,
ordering = NULL, axis_labels = NULL, cex = par("cex"), cex.axis = par("cex.axis"))
{
p <- data.frame(..., freq = freq, col, alpha, border, hide,
stringsAsFactors = FALSE)
np <- ncol(p) - 5
if (!is.null(ordering)) {
stopifnot(is.list(ordering))
if (length(ordering) != np)
stop("'ordering' argument should have ", np, " components, has ",
length(ordering))
}
n <- nrow(p)
if (missing(layer)) {
layer <- 1:n
}
p$layer <- layer
d <- p[, 1:np, drop = FALSE]
p <- p[, -c(1:np), drop = FALSE]
p$freq <- with(p, freq/sum(freq))
col <- col2rgb(p$col, alpha = TRUE)
if (!identical(alpha, FALSE)) {
col["alpha", ] <- p$alpha * 256
}
p$col <- apply(col, 2, function(x) do.call(rgb, c(as.list(x),
maxColorValue = 256)))
isch <- sapply(d, is.character)
d[isch] <- lapply(d[isch], as.factor)
if (length(blocks) == 1) {
blocks <- if (!is.na(as.logical(blocks))) {
rep(blocks, np)
}
else if (blocks == "bookends") {
c(TRUE, rep(FALSE, np - 2), TRUE)
}
}
if (is.null(axis_labels)) {
axis_labels <- names(d)
}
else {
if (length(axis_labels) != ncol(d))
stop("`axis_labels` should have length ", names(d),
", has ", length(axis_labels))
}
getp <- function(i, d, f, w = gap.width) {
a <- c(i, (1:ncol(d))[-i])
if (is.null(ordering[[i]])) {
o <- do.call(order, d[a])
}
else {
d2 <- d
d2[1] <- ordering[[i]]
o <- do.call(order, d2[a])
}
x <- c(0, cumsum(f[o])) * (1 - w)
x <- cbind(x[-length(x)], x[-1])
gap <- cumsum(c(0L, diff(as.numeric(d[o, i])) != 0))
mx <- max(gap)
if (mx == 0)
mx <- 1
gap <- gap/mx * w
(x + gap)[order(o), ]
}
dd <- lapply(seq_along(d), getp, d = d, f = p$freq)
rval <- list(endpoints = dd)
===============================================
===============Need to edit====================
op <- par(mar = c(2, 1, 1, 1))
===============================================
plot(NULL, type = "n", xlim = c(1 - cw, np + cw), ylim = c(0,
1), xaxt = "n", yaxt = "n", xaxs = "i", yaxs = "i", xlab = "",
ylab = "", frame = FALSE)
ind <- which(!p$hide)[rev(order(p[!p$hide, ]$layer))]
for (i in ind) {
for (j in 1:(np - 1)) {
xspline(c(j, j, j + xw, j + 1 - xw, j + 1, j + 1,
j + 1 - xw, j + xw, j) + rep(c(cw, -cw, cw),
c(3, 4, 2)), c(dd[[j]][i, c(1, 2, 2)], rev(dd[[j +
1]][i, c(1, 1, 2, 2)]), dd[[j]][i, c(1, 1)]),
shape = c(0, 0, 1, 1, 0, 0, 1, 1, 0, 0), open = FALSE,
col = p$col[i], border = p$border[i])
}
}
for (j in seq_along(dd)) {
ax <- lapply(split(dd[[j]], d[, j]), range)
if (blocks[j]) {
for (k in seq_along(ax)) {
rect(j - cw, ax[[k]][1], j + cw, ax[[k]][2])
}
}
else {
for (i in ind) {
x <- j + c(-1, 1) * cw
y <- t(dd[[j]][c(i, i), ])
w <- xw * (x[2] - x[1])
xspline(x = c(x[1], x[1], x[1] + w, x[2] - w,
x[2], x[2], x[2] - w, x[1] + w, x[1]), y = c(y[c(1,
2, 2), 1], y[c(2, 2, 1, 1), 2], y[c(1, 1),
1]), shape = c(0, 0, 1, 1, 0, 0, 1, 1, 0, 0),
open = FALSE, col = p$col[i], border = p$border[i])
}
}
for (k in seq_along(ax)) {
text(j, mean(ax[[k]]), labels = names(ax)[k], cex = cex)
}
}
axis(1, at = rep(c(-cw, cw), ncol(d)) + rep(seq_along(d),
each = 2), line = 0.5, col = "white", col.ticks = "black",
labels = FALSE)
axis(1, at = seq_along(d), tick = FALSE, labels = axis_labels,
cex.axis = cex.axis)
par(op)
invisible(rval)
}
I marked where the problem occur as:
================================================
==============Need to edit======================
op <- par(mar = c(2, 1, 1, 1))
================================================
After changing the line to par(mar=c(5, 5, 3, 10)) I got:
I have data:
and want to plot the correspondence analysis of that data.
md <- structure(list(Interpret_ALdc=c(11.522, 19.834, 8.122,
28.901, 20.778, 7.745, 9.634, 3.589, 8.311),
Compare_ALdc=c(10.005, 7.504, 16.008, 12.506, 12.506, 6.003,
8.004, 1.501, 1.501), Account_ALdc=c(10.503, 22.756, 9.502,
24.506, 15.754, 7.752, 6.252, 7.002, 8.252),
Interpret_MErd=c(21.536, 19.383, 1.436, 16.511, 22.254, 14.358,
27.997, 5.743, 7.897), Compare_MErd=c(18.282, 1.828, 13.711,
1.828, 6.399, 5.484, 5.484, 1.828, 2.742), Account_MErd=c(24.687,
13.167, 4.937, 9.217, 7.571, 18.433, 11.521, 16.458, 2.633)),
row.names=c("VBZ", "VM", "VVD", "VVI", "CST", "JJR", "VVZ",
"II21", "PPH1"), class="data.frame")
library(languageR)
md.ca <- corres.fnc(md)
plot(md.ca)
But some text on the right is missing on the plot. Instead of "Compare_MErd", just "Compare" presents on the plot. How to expand the plot area to present all text?
You can fit everything by setting stretch=2 or somesuch, but it will extend the window limits symmetrically.
plot(md.ca, stretch=2)
Modifying the code of plot.corres() to allow for xlim/ylim adjustment is pretty straight forward. F.ex:
plot.corres <- function (x, main = "", addcol = TRUE, extreme = 0, rcex = 1,
rcol = 1, rlabels = "", stretch, ccex = 1, ccol = 2,
clabels = "", xlim, ylim, ...)
{
if (!is(x, "corres"))
stop("argument should be a correspondence object")
dat = x#data$origOut
xlimit = range(dat$rproj[, 1])
ylimit = range(dat$rproj[, 2])
if (!missing(xlim)) {
xlimit <- xlim
}
if (!missing(ylim)) {
ylimit <- ylim
}
if (!missing(stretch)) {
xlimit = xlimit * stretch
ylimit = ylimit * stretch
}
plot(dat$rproj[, 1], dat$rproj[, 2], type = "n", xlim = xlimit,
ylim = ylimit, xlab = paste("Factor 1 (", round(x#data$eigenrates[1]/10,
1), " %)", sep = ""), ylab = paste("Factor 2 (",
round(x#data$eigenrates[2]/10, 1), " %)", sep = ""), ...)
lines(c(max(dat$rproj[, 1]), min(dat$rproj[, 1])), c(0, 0))
lines(c(0, 0), c(max(dat$rpro[, 2]), min(dat$rproj[, 2])))
if (!(main == ""))
mtext(main, 3, 1)
if (length(rcol) == 1)
rcol = rep(1, nrow(dat$rproj))
if (length(rlabels) == 1)
rlabels = rownames(x#data$input)
text(dat$rproj[, 1], dat$rproj[, 2], rlabels, cex = rcex,
col = rcol)
if (addcol) {
if (length(clabels) == 1)
clabels = colnames(x#data$input)
if (extreme > 0) {
x = data.frame(dat$cproj[, 1:2])
extremes = apply(x, 2, quantile, c(extreme, 1 - extreme))
Accept = as.factor((x[, 2] < extremes[1, 2] | x[,
2] > extremes[2, 2]) | (x[, 1] < extremes[1,
1] | x[, 1] > extremes[2, 1]))
text(x[Accept == TRUE, 1], x[Accept == TRUE, 2],
clabels[Accept == TRUE], font = 2, cex = ccex,
col = ccol)
}
else {
text(dat$cproj[, 1], dat$cproj[, 2], clabels, font = 2,
cex = ccex, col = ccol)
}
}
}
plot(md.ca, xlim=c(-0.6, 1))
You could ask the author of the function if he could revise it.
His name and contact information is at ?corres.fnc
I am trying to use twoord.plot with different dates on x axis and counts for ly and percentages for ry, and I want to remove axis 3 or change its color. Setting axes = F does not work, neither does xaxt = 'n'.
In fact, axes = FALSE gives me this error message:
Error in plot.default(lx, ly, xlim = xlim, ylim = lylim, xlab = xlab, :
formal argument "axes" matched by multiple actual arguments
The solution given here:
Remove all axis values and labels in twoord plot does not work for me with different rx and lx.
Here is a similar code to that I'm using:
set.seed(123)
library(plotrix)
twoord.plot(
lx = seq(as.Date("2016-01-01"), as.Date("2017-01-01"), by = "days"),
ly = round(runif(367) * 6),
rx = seq(as.Date("2016-05-09"), as.Date("2017-01-12"), by = "days"),
ry = sort(rnorm(249, 60, 10)),
lylim = range(round(runif(367) * 6)) + c(0, 10),
rylim = range(sort(rnorm(249, 60, 10))) + c(-35, 10),
ylab.at = mean(round(runif(367) * 6)),
rylab.at = mean(sort(rnorm(249, 60, 10))),
rylab = "Percentages %", ylab = "No. of x",
type = c("l", "l"), lcol = "skyblue4", rcol = "chocolate1" ,
xtickpos = as.numeric(seq(as.Date("2016-01-01"), as.Date("2017-01-01"), by = "months")),
xticklab = seq(as.Date("2016-01-01"), as.Date("2017-01-01"), by = "months"))
Any ideas on how to this? Thanks in advance! :)
Just hack the twoord.plot function. Here's an example to make all axis labels black (Use twoord.plot2 instead of twoord.plot when creating the plot). If you want to remove the axes altogether, just comment (add # before the lines) Lines 88-90 (For ly) and Lines 123-125 (for ry). I have left notes for them in the function below.
twoord.plot2 = function (lx, ly, rx, ry, data = NULL, main = "", xlim = NULL,
lylim = NULL, rylim = NULL, mar = c(5, 4, 4, 4), lcol = 1,
rcol = 2, xlab = "", lytickpos = NA, ylab = "", ylab.at = NA,
rytickpos = NA, rylab = "", rylab.at = NA, lpch = 1, rpch = 2,
type = "b", xtickpos = NULL, xticklab = NULL, halfwidth = 0.4,
axislab.cex = 1, do.first = NULL, ...)
{
if (!is.null(data)) {
ly <- unlist(data[ly])
ry <- unlist(data[ry])
if (missing(lx))
lx <- 1:length(ly)
else lx <- unlist(data[lx])
if (missing(rx))
rx <- 1:length(ry)
else rx <- unlist(data[rx])
}
if (missing(lx))
lx <- 1:length(ly)
if (missing(ry)) {
if (missing(rx)) {
rx <- 1:length(ry)
ry <- ly
ly <- lx
lx <- 1:length(ly)
}
else {
ry <- rx
rx <- 1:length(ry)
}
}
oldmar <- par("mar")
par(mar = mar)
if (is.null(xlim))
xlim <- range(c(lx, rx))
if (missing(lx))
lx <- 1:length(ly)
if (is.null(lylim)) {
lylim <- range(ly, na.rm = TRUE)
lyspan <- diff(lylim)
if (lyspan == 0)
lyspan <- lylim[1]
lylim[2] <- lylim[2] + lyspan * 0.04
if (lylim[1] != 0)
lylim[1] <- lylim[1] - lyspan * 0.04
}
if (length(type) < 2)
type <- rep(type, 2)
if (match(type[1], "bar", 0)) {
oldcex <- par(cex = axislab.cex)
plot(lx, ly, xlim = xlim, ylim = lylim, xlab = xlab,
ylab = "", yaxs = "i", type = "n", main = "", axes = FALSE,
...)
par(oldcex)
if (!is.null(do.first))
eval(parse(text = do.first))
ybottom <- par("usr")[3]
if (lylim[1] < 0)
abline(h = 0, lty = 2)
rect(lx - halfwidth, ifelse(ly < 0, ly, ybottom), lx +
halfwidth, ifelse(ly > 0, ly, 0), col = lcol)
}
else {
oldcex <- par(cex = axislab.cex)
plot(lx, ly, xlim = xlim, ylim = lylim, xlab = xlab,
ylab = "", yaxs = "i", type = "n", main = "", axes = FALSE,
...)
par(oldcex)
if (!is.null(do.first))
eval(parse(text = do.first))
points(lx, ly, col = lcol, pch = lpch, type = type[1],
...)
}
title(main = main)
xylim <- par("usr")
box()
if (is.null(xticklab))
axis(1, cex.axis = axislab.cex)
else {
if (is.null(xtickpos))
xtickpos <- 1:length(xticklab)
axis(1, at = xtickpos, labels = xticklab, cex.axis = axislab.cex)
}
if (is.na(lytickpos[1]))
lytickpos <- pretty(ly)
if (is.na(ylab.at))
ylab.at <- mean(lytickpos)
color.axis(2, at = lytickpos, axlab = ylab, axlab.at = ylab.at, #LINE 88
col = "black", cex.axis = axislab.cex, #col = ifelse(is.na(lcol), 1, lcol), cex.axis = axislab.cex,
cex = axislab.cex) #LINE 90
if (is.null(rylim)) {
rylim <- range(ry, na.rm = TRUE)
ryspan <- diff(rylim)
if (ryspan == 0)
ryspan <- rylim[1]
rylim[2] <- rylim[2] + ryspan * 0.04
if (rylim[1] != 0)
rylim[1] <- rylim[1] - ryspan * 0.04
}
ymult <- diff(lylim)/diff(rylim)
yoff <- lylim[1] - rylim[1] * ymult
if (match(type[2], "bar", 0)) {
if (rylim[1] < 0)
abline("h", 0)
rect(rx - halfwidth, ifelse(ry < 0, ry, rylim[1] * ymult +
yoff), rx + halfwidth, ifelse(ry > 0, ry * ymult +
yoff, 0), col = rcol)
}
else points(rx, ry * ymult + yoff, col = rcol, pch = rpch,
type = type[2], ...)
if (is.na(rytickpos[1]))
rylabels <- pretty(rylim)
else rylabels <- rytickpos
if (min(rylabels) < rylim[1])
rylabels <- rylabels[rylabels >= rylim[1]]
if (max(rylabels) > rylim[2])
rylabels <- rylabels[rylabels <= rylim[2]]
axat <- rylabels * ymult + yoff
if (is.na(rylab.at))
rylab.at <- mean(rytickpos)
if (!is.na(rylab.at))
rylab.at <- rylab.at * ymult + yoff
color.axis(4, at = axat, labels = rylabels, axlab = rylab, #LINE 123
axlab.at = rylab.at, col = "black", #axlab.at = rylab.at, col = ifelse(is.na(rcol), 1, rcol),
cex.axis = axislab.cex, cex = axislab.cex) #LINE 125
par(mar = oldmar, new = FALSE, col.axis = "black")
}
I've been working on a HTML document with Rmarkdown.
The document has several sp plots and ggplots and all of them appear in the HTML.
But when I call plotK (which is a function from stpp package to plot the spatio-temporal inhomogeneous k-funtion - STIKhat), the plot doesnt appear in the HTML.
Here's a reproducible example for Rmarkdown:
---
title: "Untitled"
output: html_document
---
```{r}
library(stpp)
data(fmd)
data(northcumbria)
FMD<-as.3dpoints(fmd[,1]/1000,fmd[,2]/1000,fmd[,3])
Northcumbria=northcumbria/1000
# estimation of the temporal intensity
Mt<-density(FMD[,3],n=1000)
mut<-Mt$y[findInterval(FMD[,3],Mt$x)]*dim(FMD)[1]
# estimation of the spatial intensity
h<-mse2d(as.points(FMD[,1:2]), Northcumbria, nsmse=50, range=4)
h<-h$h[which.min(h$mse)]
Ms<-kernel2d(as.points(FMD[,1:2]), Northcumbria, h, nx=5000, ny=5000)
atx<-findInterval(x=FMD[,1],vec=Ms$x)
aty<-findInterval(x=FMD[,2],vec=Ms$y)
mhat<-NULL
for(i in 1:length(atx)) mhat<-c(mhat,Ms$z[atx[i],aty[i]])
# estimation of the STIK function
u <- seq(0,10,by=1)
v <- seq(0,15,by=1)
stik1 <- STIKhat(xyt=FMD, s.region=northcumbria/1000,t.region=c(1,200),
lambda=mhat*mut/dim(FMD)[1], dist=u, times=v, infectious=TRUE)
```
```{r}
plotK(stik1)
```
after knitting, the plot doesnt appear in HTML. Does anyone has some idea what is going on?
Thank you so much!
This question is a little stale, but I couldn't help but take #ryanm comment (that I just noticed) as a fun challenge. As I mentioned in the comment above, the problem lies in how the plotK function is manipulating devices. Some trimming of (unnecessary?) code in the plotK function solves the problem:
---
title: "Untitled"
output: html_document
---
```{r}
library(stpp)
data(fmd)
data(northcumbria)
FMD<-as.3dpoints(fmd[,1]/1000,fmd[,2]/1000,fmd[,3])
Northcumbria=northcumbria/1000
# estimation of the temporal intensity
Mt<-density(FMD[,3],n=1000)
mut<-Mt$y[findInterval(FMD[,3],Mt$x)]*dim(FMD)[1]
# estimation of the spatial intensity
h<-mse2d(as.points(FMD[,1:2]), Northcumbria, nsmse=50, range=4)
h<-h$h[which.min(h$mse)]
Ms<-kernel2d(as.points(FMD[,1:2]), Northcumbria, h, nx=5000, ny=5000)
atx<-findInterval(x=FMD[,1],vec=Ms$x)
aty<-findInterval(x=FMD[,2],vec=Ms$y)
mhat<-NULL
for(i in 1:length(atx)) mhat<-c(mhat,Ms$z[atx[i],aty[i]])
# estimation of the STIK function
u <- seq(0,10,by=1)
v <- seq(0,15,by=1)
stik1 <- STIKhat(xyt=FMD, s.region=northcumbria/1000,t.region=c(1,200),
lambda=mhat*mut/dim(FMD)[1], dist=u, times=v, infectious=TRUE)
```
```{r,echo=FALSE}
plotK <- function (K, n = 15, L = FALSE, type = "contour", legend = TRUE,
which = NULL, main = NULL, ...)
{
old.par <- par(no.readonly = TRUE)
on.exit(par(old.par))
correc = c("none", "isotropic", "border", "modified.border",
"translate")
correc2 = K$correction
id <- match(correc2, correc, nomatch = NA)
if ((is.null(which) && length(id) > 1) || any(is.na(match(which,
correc, nomatch = NA)))) {
mess <- paste("Please specify the argument 'which', among:",
paste(dQuote(correc2), collapse = ", "))
stop(mess, call. = FALSE)
}
if (isTRUE(K$infectious))
which = "isotropic"
if (is.matrix(K$Khat)) {
if (is.null(which))
which = correc2
else {
if (!(is.null(which)) && which != correc2) {
mess <- paste("Argument 'which' should be", paste(dQuote(correc2),
collapse = ", "))
stop(mess, call. = FALSE)
}
}
}
if (!is.matrix(K$Khat)) {
id <- match(which, correc2, nomatch = NA)
if (is.na(id)) {
mess <- paste("Please specify the argument 'which', among:",
paste(dQuote(correc2), collapse = ", "))
stop(mess, call. = FALSE)
}
else K$Khat = K$Khat[[id]]
}
if (!is.null(main)) {
titl = main
subtitl = ""
if (isTRUE(L))
k <- K$Khat - K$Ktheo
else k <- K$Khat
}
else {
if (isTRUE(L)) {
k <- K$Khat - K$Ktheo
subtitl <- paste("edge correction method: ", which,
sep = "")
if (isTRUE(K$infectious))
titl <- expression(hat(K)[ST] * group("(", list(u,
v), ")") - pi * u^2 * v)
else titl <- expression(hat(K)[ST] * group("(", list(u,
v), ")") - 2 * pi * u^2 * v)
}
else {
k <- K$Khat
titl = expression(hat(K)[ST] * group("(", list(u,
v), ")"))
subtitl <- paste("edge correction method: ", which,
sep = "")
}
}
typeplot = c("contour", "image", "persp")
id <- match(type, typeplot, nomatch = NA)
if (any(nbg <- is.na(id))) {
mess <- paste("unrecognised plot type:", paste(dQuote(type[nbg]),
collapse = ", "))
stop(mess, call. = FALSE)
}
if ((length(id) != 1) || is.na(id))
stop("Please specify one type among \"contour\", \"image\" and \"persp\" ")
typeplot = rep(0, 3)
typeplot[id] = 1
colo <- colorRampPalette(c("red", "white", "blue"))
M <- max(abs(range(k)))
M <- pretty(c(-M, M), n = n)
n <- length(M)
COL <- colo(n)
if (typeplot[3] == 1) {
mask <- matrix(0, ncol = length(K$times), nrow = length(K$dist))
for (i in 1:length(K$dist)) {
for (j in 1:length(K$times)) {
mask[i, j] <- COL[findInterval(x = k[i, j], vec = M)]
}
}
COL <- mask[1:(length(K$dist) - 1), 1:(length(K$times) -
1)]
if (isTRUE(legend)) {
par(cex.lab = 2, cex.axis = 1.5, font = 2, lwd = 1,
mar = c(0, 0, 3, 0))
par(fig = c(0, 0.825, 0, 1))
persp(x = K$dist, y = K$times, z = k, xlab = "u",
ylab = "v", zlab = "", expand = 1, col = COL,
...)
title(titl, cex.main = 1.5, sub = subtitl, outer = TRUE,
line = -1)
par(fig = c(0.825, 1, 0, 1))
mini <- findInterval(x = min(k, na.rm = TRUE), vec = M)
maxi <- findInterval(x = max(k, na.rm = TRUE), vec = M)
legend("right", fill = colo(n)[maxi:mini], legend = M[maxi:mini],
horiz = F, bty = "n")
}
else {
par(cex.lab = 2, cex.axis = 1.5, font = 2, lwd = 1)
persp(x = K$dist, y = K$times, z = k, xlab = "u",
ylab = "v", zlab = "", expand = 1, col = COL,
...)
title(titl, cex.main = 1.5, sub = subtitl)
}
}
if (typeplot[1] == 1) {
if (isTRUE(legend)) {
par(cex.lab = 1.5, cex.axis = 1.5, font = 2, plt = c(0,
1, 0, 1), lwd = 1, mar = c(0.5, 0.5, 2.5, 0.5),
las = 1)
par(fig = c(0.1, 0.825, 0.1, 1))
contour(K$dist, K$times, k, labcex = 1.5, levels = M,
drawlabels = F, col = colo(n), zlim = range(M),
axes = F)
box(lwd = 2)
at <- axTicks(1)
axis(1, at = at[1:length(at)], labels = at[1:length(at)])
at <- axTicks(2)
axis(2, at = at[1:length(at)], labels = at[1:length(at)])
title(titl, cex.main = 1.5, sub = subtitl, outer = TRUE,
line = -1)
par(fig = c(0, 1, 0.1, 1))
mini <- findInterval(x = min(k, na.rm = TRUE), vec = M)
maxi <- findInterval(x = max(k, na.rm = TRUE), vec = M)
legend("right", fill = colo(n)[maxi:mini], legend = M[maxi:mini],
horiz = F, bty = "n")
}
else {
par(cex.lab = 2, cex.axis = 1.5, font = 2, lwd = 2,
las = 1)
contour(K$dist, K$times, k, labcex = 1.5, levels = M,
drawlabels = T, col = colo(n), zlim = range(M),
axes = F)
box(lwd = 2)
at <- axTicks(1)
axis(1, at = at[1:length(at)], labels = at[1:length(at)])
at <- axTicks(2)
axis(2, at = at[1:length(at)], labels = at[1:length(at)])
title(titl, cex.main = 1.5, sub = subtitl)
}
}
if (typeplot[2] == 1) {
if (isTRUE(legend)) {
par(cex.lab = 1.5, cex.axis = 1.5, font = 2, lwd = 1,
plt = c(0, 1, 0, 1), mar = c(0.5, 0.5, 2.5, 0.5),
las = 1)
par(fig = c(0.1, 0.825, 0.1, 1))
image(K$dist, K$times, k, col = colo(n), zlim = range(M),
axes = F, xlab = "", ylab = "")
box(lwd = 2)
at <- axTicks(1)
axis(1, at = at[1:length(at)], labels = at[1:length(at)])
at <- axTicks(2)
axis(2, at = at[1:length(at)], labels = at[1:length(at)])
title(titl, cex.main = 1.5, sub = subtitl, outer = TRUE,
line = -1)
par(fig = c(0, 1, 0.1, 1))
mini <- findInterval(x = min(k, na.rm = TRUE), vec = M)
maxi <- findInterval(x = max(k, na.rm = TRUE), vec = M)
legend("right", fill = colo(n)[maxi:mini], legend = M[maxi:mini],
horiz = F, bty = "n")
}
else {
par(cex.lab = 2, cex.axis = 1.5, font = 2, lwd = 2,
las = 1)
image(K$dist, K$times, k, col = colo(n), zlim = range(M),
axes = F, xlab = "", ylab = "")
box(lwd = 2)
at <- axTicks(1)
axis(1, at = at[1:length(at)], labels = at[1:length(at)])
at <- axTicks(2)
axis(2, at = at[1:length(at)], labels = at[1:length(at)])
title(titl, cex.main = 1.5, sub = subtitl)
}
}
par(old.par)
}
```
```{r}
plotK(stik1)
```
If you use the stpp package often, it might be worth an e-mail to the maintainer about why messing with the device is necessary.
Try this with some extra packages in your plotting chunk:
library(png)
library(grid)
library(gridExtra)
plotK(stik1)
dev.print(png, "plot.png", width=480, height=480)
img <- readPNG("plot.png")
img <- rasterGrob(img)
grid.draw(img)
I am plotting correlation plot with corrplot. I want to plot also the correlation coefficients:
require(corrplot)
test <- matrix(data = rnorm(400), nrow=20, ncol=20)
corrplot(cor(test), method = "color", addCoef.col="grey", order = "AOE")
But they are too big in the plot:
Is there any way to make the font of the coefficent smaller? I've been looking at ?corrplot but there are only parameters to change the legend and axis font sizes (cl.cex and tl.cex). pch.cex doesn't work either.
The option to use is number.cex=.
As in the following:
corrplot(cor(test),
method = "color",
addCoef.col="grey",
order = "AOE",
number.cex=0.75)
To make it dynamic, try number.cex= 7/ncol(df) where df is dataframe for which the correlation was run.
It is far from the answer, it is kind of a dirty hack, but this works (thanks user20650 for the idea):
cex.before <- par("cex")
par(cex = 0.7)
corrplot(cor(envV), p.mat = cor1[[1]], insig = "blank", method = "color",
addCoef.col="grey",
order = "AOE", tl.cex = 1/par("cex"),
cl.cex = 1/par("cex"), addCoefasPercent = TRUE)
par(cex = cex.before)
I had exactly the same problem a little while ago when I had to do a corrplot similar to yours. After a lot of searching I found a solution which involves printing the correlation plot to a png file and altering the parameters there.
i.e.:
library(corrplot)
test <- matrix(data = rnorm(400), nrow=20, ncol=20)
png(height=1200, width=1500, pointsize=15, file="overlap.png")
corrplot(cor(test), method = "color", addCoef.col="grey", order = "AOE")
The part that increases/decreases the font inside the cells is parameter pointsize. setting it to 15 you can see that the numbers now fit the cells.
You may also find this link helpful. it certainly helped me.
I would define my own size value since the function just ommited allowing for a size to be added to that text. Below is the function recreated with an extra number.cex paramater added at the end, which controls the number label size now.
corrplot2 <- function (corr, method = c("circle", "square", "ellipse", "number",
"shade", "color", "pie"), type = c("full", "lower", "upper"),
add = FALSE, col = NULL, bg = "white", title = "", is.corr = TRUE,
diag = TRUE, outline = FALSE, mar = c(0, 0, 0, 0), addgrid.col = NULL,
addCoef.col = NULL, addCoefasPercent = FALSE, order = c("original",
"AOE", "FPC", "hclust", "alphabet"), hclust.method = c("complete",
"ward", "single", "average", "mcquitty", "median", "centroid"),
addrect = NULL, rect.col = "black", rect.lwd = 2, tl.pos = NULL,
tl.cex = 1, tl.col = "red", tl.offset = 0.4, tl.srt = 90,
cl.pos = NULL, cl.lim = NULL, cl.length = NULL, cl.cex = 0.8,
cl.ratio = 0.15, cl.align.text = "c", cl.offset = 0.5, addshade = c("negative",
"positive", "all"), shade.lwd = 1, shade.col = "white",
p.mat = NULL, sig.level = 0.05, insig = c("pch", "p-value",
"blank", "n"), pch = 4, pch.col = "black", pch.cex = 3,
plotCI = c("n", "square", "circle", "rect"), lowCI.mat = NULL,
uppCI.mat = NULL, number.cex = 0.7, ...)
{
method <- match.arg(method)
type <- match.arg(type)
order <- match.arg(order)
hclust.method <- match.arg(hclust.method)
plotCI <- match.arg(plotCI)
insig <- match.arg(insig)
if (!is.matrix(corr) & !is.data.frame(corr))
stop("Need a matrix or data frame!")
if (is.null(addgrid.col)) {
addgrid.col <- ifelse(method == "color" | method == "shade",
"white", "grey")
}
if (any(corr < cl.lim[1]) | any(corr > cl.lim[2]))
stop("color limits should cover matrix")
if (is.null(cl.lim)) {
if (is.corr)
cl.lim <- c(-1, 1)
if (!is.corr)
cl.lim <- c(min(corr), max(corr))
}
intercept <- 0
zoom <- 1
if (!is.corr) {
if (max(corr) * min(corr) < 0) {
intercept <- 0
zoom <- 1/max(abs(cl.lim))
}
if (min(corr) >= 0) {
intercept <- -cl.lim[1]
zoom <- 1/(diff(cl.lim))
}
if (max(corr) <= 0) {
intercept <- -cl.lim[2]
zoom <- 1/(diff(cl.lim))
}
corr <- (intercept + corr) * zoom
}
cl.lim2 <- (intercept + cl.lim) * zoom
int <- intercept * zoom
if (min(corr) < -1 - .Machine$double.eps || max(corr) > 1 +
.Machine$double.eps) {
stop("The matrix is not in [-1, 1]!")
}
if (is.null(col)) {
col <- colorRampPalette(c("#67001F", "#B2182B", "#D6604D",
"#F4A582", "#FDDBC7", "#FFFFFF", "#D1E5F0", "#92C5DE",
"#4393C3", "#2166AC", "#053061"))(200)
}
n <- nrow(corr)
m <- ncol(corr)
min.nm <- min(n, m)
ord <- 1:min.nm
if (!order == "original") {
ord <- corrMatOrder(corr, order = order, hclust.method = hclust.method)
corr <- corr[ord, ord]
}
if (is.null(rownames(corr)))
rownames(corr) <- 1:n
if (is.null(colnames(corr)))
colnames(corr) <- 1:m
getPos.Dat <- function(mat) {
x <- matrix(1:n * m, n, m)
tmp <- mat
if (type == "upper")
tmp[row(x) > col(x)] <- Inf
if (type == "lower")
tmp[row(x) < col(x)] <- Inf
if (type == "full")
tmp <- tmp
if (!diag)
diag(tmp) <- Inf
Dat <- tmp[is.finite(tmp)]
ind <- which(is.finite(tmp), arr.ind = TRUE)
Pos <- ind
Pos[, 1] <- ind[, 2]
Pos[, 2] <- -ind[, 1] + 1 + n
return(list(Pos, Dat))
}
Pos <- getPos.Dat(corr)[[1]]
n2 <- max(Pos[, 2])
n1 <- min(Pos[, 2])
nn <- n2 - n1
newrownames <- as.character(rownames(corr)[(n + 1 - n2):(n +
1 - n1)])
m2 <- max(Pos[, 1])
m1 <- min(Pos[, 1])
mm <- m2 - m1
newcolnames <- as.character(colnames(corr)[m1:m2])
DAT <- getPos.Dat(corr)[[2]]
len.DAT <- length(DAT)
assign.color <- function(DAT) {
newcorr <- (DAT + 1)/2
newcorr[newcorr == 1] <- 1 - 0.0000000001
col.fill <- col[floor(newcorr * length(col)) + 1]
}
col.fill <- assign.color(DAT)
isFALSE = function(x) identical(x, FALSE)
isTRUE = function(x) identical(x, TRUE)
if (isFALSE(tl.pos)) {
tl.pos <- "n"
}
if (is.null(tl.pos) | isTRUE(tl.pos)) {
if (type == "full")
tl.pos <- "lt"
if (type == "lower")
tl.pos <- "ld"
if (type == "upper")
tl.pos <- "td"
}
if (isFALSE(cl.pos)) {
cl.pos <- "n"
}
if (is.null(cl.pos) | isTRUE(cl.pos)) {
if (type == "full")
cl.pos <- "r"
if (type == "lower")
cl.pos <- "b"
if (type == "upper")
cl.pos <- "r"
}
if (outline)
col.border <- "black"
if (!outline)
col.border <- col.fill
if (!add) {
par(mar = mar, bg = "white")
plot.new()
xlabwidth <- ylabwidth <- 0
for (i in 1:50) {
xlim <- c(m1 - 0.5 - xlabwidth, m2 + 0.5 + mm * cl.ratio *
(cl.pos == "r"))
ylim <- c(n1 - 0.5 - nn * cl.ratio * (cl.pos == "b"),
n2 + 0.5 + ylabwidth)
plot.window(xlim + c(-0.2, 0.2), ylim + c(-0.2, 0.2),
asp = 1, xaxs = "i", yaxs = "i")
x.tmp <- max(strwidth(newrownames, cex = tl.cex))
y.tmp <- max(strwidth(newcolnames, cex = tl.cex))
if (min(x.tmp - xlabwidth, y.tmp - ylabwidth) < 0.0001)
break
xlabwidth <- x.tmp
ylabwidth <- y.tmp
}
if (tl.pos == "n" | tl.pos == "d")
xlabwidth <- ylabwidth <- 0
if (tl.pos == "td")
ylabwidth <- 0
if (tl.pos == "ld")
xlabwidth <- 0
laboffset <- strwidth("W", cex = tl.cex) * tl.offset
xlim <- c(m1 - 0.5 - xlabwidth - laboffset, m2 + 0.5 +
mm * cl.ratio * (cl.pos == "r")) + c(-0.35, 0.15)
ylim <- c(n1 - 0.5 - nn * cl.ratio * (cl.pos == "b"),
n2 + 0.5 + ylabwidth * abs(sin(tl.srt * pi/180)) +
laboffset) + c(-0.15, 0.35)
if (.Platform$OS.type == "windows") {
windows.options(width = 7, height = 7 * diff(ylim)/diff(xlim))
}
plot.window(xlim = xlim, ylim = ylim, asp = 1, xlab = "",
ylab = "", xaxs = "i", yaxs = "i")
}
laboffset <- strwidth("W", cex = tl.cex) * tl.offset
symbols(Pos, add = TRUE, inches = FALSE, squares = rep(1,
len.DAT), bg = bg, fg = bg)
if (method == "circle" & plotCI == "n") {
symbols(Pos, add = TRUE, inches = FALSE, bg = col.fill,
circles = 0.9 * abs(DAT)^0.5/2, fg = col.border)
}
if (method == "ellipse" & plotCI == "n") {
ell.dat <- function(rho, length = 99) {
k <- seq(0, 2 * pi, length = length)
x <- cos(k + acos(rho)/2)/2
y <- cos(k - acos(rho)/2)/2
return(cbind(rbind(x, y), c(NA, NA)))
}
ELL.dat <- lapply(DAT, ell.dat)
ELL.dat2 <- 0.85 * matrix(unlist(ELL.dat), ncol = 2,
byrow = TRUE)
ELL.dat2 <- ELL.dat2 + Pos[rep(1:length(DAT), each = 100),
]
polygon(ELL.dat2, border = col.border, col = col.fill)
}
if (method == "number" & plotCI == "n") {
text(Pos[, 1], Pos[, 2], font = 2, col = col.fill, labels = round((DAT -
int) * ifelse(addCoefasPercent, 100, 1)/zoom, ifelse(addCoefasPercent,
0, 2)))
}
if (method == "pie" & plotCI == "n") {
symbols(Pos, add = TRUE, inches = FALSE, circles = rep(0.5,
len.DAT) * 0.85)
pie.dat <- function(theta, length = 100) {
k <- seq(pi/2, pi/2 - theta, length = 0.5 * length *
abs(theta)/pi)
x <- c(0, cos(k)/2, 0)
y <- c(0, sin(k)/2, 0)
return(cbind(rbind(x, y), c(NA, NA)))
}
PIE.dat <- lapply(DAT * 2 * pi, pie.dat)
len.pie <- unlist(lapply(PIE.dat, length))/2
PIE.dat2 <- 0.85 * matrix(unlist(PIE.dat), ncol = 2,
byrow = TRUE)
PIE.dat2 <- PIE.dat2 + Pos[rep(1:length(DAT), len.pie),
]
polygon(PIE.dat2, border = "black", col = col.fill)
}
if (method == "shade" & plotCI == "n") {
addshade <- match.arg(addshade)
symbols(Pos, add = TRUE, inches = FALSE, squares = rep(1,
len.DAT), bg = col.fill, fg = addgrid.col)
shade.dat <- function(w) {
x <- w[1]
y <- w[2]
rho <- w[3]
x1 <- x - 0.5
x2 <- x + 0.5
y1 <- y - 0.5
y2 <- y + 0.5
dat <- NA
if ((addshade == "positive" || addshade == "all") &
rho > 0) {
dat <- cbind(c(x1, x1, x), c(y, y1, y1), c(x,
x2, x2), c(y2, y2, y))
}
if ((addshade == "negative" || addshade == "all") &
rho < 0) {
dat <- cbind(c(x1, x1, x), c(y, y2, y2), c(x,
x2, x2), c(y1, y1, y))
}
return(t(dat))
}
pos_corr <- rbind(cbind(Pos, DAT))
pos_corr2 <- split(pos_corr, 1:nrow(pos_corr))
SHADE.dat <- matrix(na.omit(unlist(lapply(pos_corr2,
shade.dat))), byrow = TRUE, ncol = 4)
segments(SHADE.dat[, 1], SHADE.dat[, 2], SHADE.dat[,
3], SHADE.dat[, 4], col = shade.col, lwd = shade.lwd)
}
if (method == "square" & plotCI == "n") {
symbols(Pos, add = TRUE, inches = FALSE, squares = abs(DAT)^0.5,
bg = col.fill, fg = col.border)
}
if (method == "color" & plotCI == "n") {
symbols(Pos, add = TRUE, inches = FALSE, squares = rep(1,
len.DAT), bg = col.fill, fg = col.border)
}
symbols(Pos, add = TRUE, inches = FALSE, bg = NA, squares = rep(1,
len.DAT), fg = addgrid.col)
if (plotCI != "n") {
if (is.null(lowCI.mat) || is.null(uppCI.mat))
stop("Need lowCI.mat and uppCI.mat!")
if (!order == "original") {
lowCI.mat <- lowCI.mat[ord, ord]
uppCI.mat <- uppCI.mat[ord, ord]
}
pos.lowNew <- getPos.Dat(lowCI.mat)[[1]]
lowNew <- getPos.Dat(lowCI.mat)[[2]]
pos.uppNew <- getPos.Dat(uppCI.mat)[[1]]
uppNew <- getPos.Dat(uppCI.mat)[[2]]
if (!(method == "circle" || method == "square"))
stop("method shoud be circle or square if draw confidence interval!")
k1 <- (abs(uppNew) > abs(lowNew))
bigabs <- uppNew
bigabs[which(!k1)] <- lowNew[!k1]
smallabs <- lowNew
smallabs[which(!k1)] <- uppNew[!k1]
sig <- sign(uppNew * lowNew)
if (plotCI == "circle") {
symbols(pos.uppNew[, 1], pos.uppNew[, 2], add = TRUE,
inches = FALSE, circles = 0.95 * abs(bigabs)^0.5/2,
bg = ifelse(sig > 0, col.fill, col[ceiling((bigabs +
1) * length(col)/2)]), fg = ifelse(sig > 0,
col.fill, col[ceiling((bigabs + 1) * length(col)/2)]))
symbols(pos.lowNew[, 1], pos.lowNew[, 2], add = TRUE,
inches = FALSE, circles = 0.95 * abs(smallabs)^0.5/2,
bg = ifelse(sig > 0, bg, col[ceiling((smallabs +
1) * length(col)/2)]), fg = ifelse(sig > 0,
col.fill, col[ceiling((smallabs + 1) * length(col)/2)]))
}
if (plotCI == "square") {
symbols(pos.uppNew[, 1], pos.uppNew[, 2], add = TRUE,
inches = FALSE, squares = abs(bigabs)^0.5, bg = ifelse(sig >
0, col.fill, col[ceiling((bigabs + 1) * length(col)/2)]),
fg = ifelse(sig > 0, col.fill, col[ceiling((bigabs +
1) * length(col)/2)]))
symbols(pos.lowNew[, 1], pos.lowNew[, 2], add = TRUE,
inches = FALSE, squares = abs(smallabs)^0.5,
bg = ifelse(sig > 0, bg, col[ceiling((smallabs +
1) * length(col)/2)]), fg = ifelse(sig > 0,
col.fill, col[ceiling((smallabs + 1) * length(col)/2)]))
}
if (plotCI == "rect") {
rect.width <- 0.25
rect(pos.uppNew[, 1] - rect.width, pos.uppNew[, 2] +
smallabs/2, pos.uppNew[, 1] + rect.width, pos.uppNew[,
2] + bigabs/2, col = col.fill, border = col.fill)
segments(pos.lowNew[, 1] - rect.width, pos.lowNew[,
2] + DAT/2, pos.lowNew[, 1] + rect.width, pos.lowNew[,
2] + DAT/2, col = "black", lwd = 1)
segments(pos.uppNew[, 1] - rect.width, pos.uppNew[,
2] + uppNew/2, pos.uppNew[, 1] + rect.width,
pos.uppNew[, 2] + uppNew/2, col = "black", lwd = 1)
segments(pos.lowNew[, 1] - rect.width, pos.lowNew[,
2] + lowNew/2, pos.lowNew[, 1] + rect.width,
pos.lowNew[, 2] + lowNew/2, col = "black", lwd = 1)
segments(pos.lowNew[, 1] - 0.5, pos.lowNew[, 2],
pos.lowNew[, 1] + 0.5, pos.lowNew[, 2], col = "grey70",
lty = 3)
}
}
if (!is.null(p.mat) & !insig == "n") {
if (!order == "original")
p.mat <- p.mat[ord, ord]
pos.pNew <- getPos.Dat(p.mat)[[1]]
pNew <- getPos.Dat(p.mat)[[2]]
ind.p <- which(pNew > (sig.level))
if (insig == "pch") {
points(pos.pNew[, 1][ind.p], pos.pNew[, 2][ind.p],
pch = pch, col = pch.col, cex = pch.cex, lwd = 2)
}
if (insig == "p-value") {
text(pos.pNew[, 1][ind.p], pos.pNew[, 2][ind.p],
round(pNew[ind.p], 2), col = pch.col)
}
if (insig == "blank") {
symbols(pos.pNew[, 1][ind.p], pos.pNew[, 2][ind.p],
inches = FALSE, squares = rep(1, length(pos.pNew[,
1][ind.p])), fg = addgrid.col, bg = bg, add = TRUE)
}
}
if (cl.pos != "n") {
colRange <- assign.color(cl.lim2)
ind1 <- which(col == colRange[1])
ind2 <- which(col == colRange[2])
colbar <- col[ind1:ind2]
if (is.null(cl.length))
cl.length <- ifelse(length(colbar) > 20, 11, length(colbar) +
1)
labels <- seq(cl.lim[1], cl.lim[2], length = cl.length)
at <- seq(0, 1, length = length(labels))
if (cl.pos == "r") {
vertical <- TRUE
xlim <- c(m2 + 0.5 + mm * 0.02, m2 + 0.5 + mm * cl.ratio)
ylim <- c(n1 - 0.5, n2 + 0.5)
}
if (cl.pos == "b") {
vertical <- FALSE
xlim <- c(m1 - 0.5, m2 + 0.5)
ylim <- c(n1 - 0.5 - nn * cl.ratio, n1 - 0.5 - nn *
0.02)
}
colorlegend(colbar = colbar, labels = round(labels, 2),
offset = cl.offset, ratio.colbar = 0.3, cex = cl.cex,
xlim = xlim, ylim = ylim, vertical = vertical, align = cl.align.text)
}
if (tl.pos != "n") {
ylabwidth2 <- strwidth(newrownames, cex = tl.cex)
xlabwidth2 <- strwidth(newcolnames, cex = tl.cex)
pos.xlabel <- cbind(m1:m2, n2 + 0.5 + laboffset)
pos.ylabel <- cbind(m1 - 0.5, n2:n1)
if (tl.pos == "td") {
if (type != "upper")
stop("type should be \"upper\" if tl.pos is \"dt\".")
pos.ylabel <- cbind(m1:(m1 + nn) - 0.5, n2:n1)
}
if (tl.pos == "ld") {
if (type != "lower")
stop("type should be \"lower\" if tl.pos is \"ld\".")
pos.xlabel <- cbind(m1:m2, n2:(n2 - mm) + 0.5 + laboffset)
}
if (tl.pos == "d") {
pos.ylabel <- cbind(m1:(m1 + nn) - 0.5, n2:n1)
pos.ylabel <- pos.ylabel[1:min(n, m), ]
symbols(pos.ylabel[, 1] + 0.5, pos.ylabel[, 2], add = TRUE,
bg = bg, fg = addgrid.col, inches = FALSE, squares = rep(1,
length(pos.ylabel[, 1])))
text(pos.ylabel[, 1] + 0.5, pos.ylabel[, 2], newcolnames[1:min(n,
m)], col = tl.col, cex = tl.cex, ...)
}
else {
text(pos.xlabel[, 1], pos.xlabel[, 2], newcolnames,
srt = tl.srt, adj = ifelse(tl.srt == 0, c(0.5,
0), c(0, 0)), col = tl.col, cex = tl.cex, offset = tl.offset,
...)
text(pos.ylabel[, 1], pos.ylabel[, 2], newrownames,
col = tl.col, cex = tl.cex, pos = 2, offset = tl.offset,
...)
}
}
title(title, ...)
if (!is.null(addCoef.col) & (!method == "number")) {
text(Pos[, 1], Pos[, 2], col = addCoef.col, labels = round((DAT -
int) * ifelse(addCoefasPercent, 100, 1)/zoom, ifelse(addCoefasPercent,
0, 2)), cex = number.cex)
}
if (type == "full" & plotCI == "n" & !is.null(addgrid.col))
rect(m1 - 0.5, n1 - 0.5, m2 + 0.5, n2 + 0.5, border = addgrid.col)
if (!is.null(addrect) & order == "hclust" & type == "full") {
corrRect.hclust(corr, k = addrect, method = hclust.method,
col = rect.col, lwd = rect.lwd)
}
invisible(corr)
}