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:
Could You please help to modify this function so that lower.panel plot circles are colored and color is dependent of specific value of factor column? I have similar data to "Iris" data.frame, so, the factor column could be 'species'. I highlighted the part where i was trying to mold 'bg' function, that works for 'pairs'.
Here is the code i'm trying to adjust:
#### chart.Correlation
function (R,histogram = TRUE, method = c("pearson", "kendall",
"spearman"), ...)
{
x = checkData(R, method = "matrix")
if (missing(method))
method = method[1]
panel.cor <- function(x, y, digits = 2, prefix = "", use = "pairwise.complete.obs",
method = "pearson", cex.cor, ...) {
usr <- par("usr")
on.exit(par(usr))
par(usr = c(0, 1, 0, 1))
r <- cor(x, y, use = use, method = method)
txt <- format(c(r, 0.123456789), digits = digits)[1]
txt <- paste(prefix, txt, sep = "")
if (missing(cex.cor))
cex <- 0.8/strwidth(txt)
test <- cor.test(as.numeric(x), as.numeric(y), method = method)
Signif <- symnum(test$p.value, corr = FALSE, na = FALSE,
cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1), symbols = c("***",
"**", "*", ".", " "))
text(0.5, 0.5, txt, cex = cex * (abs(r) + 0.3)/1.3)
text(0.8, 0.8, Signif, cex = cex, col = 2)
}
f <- function(t) {
dnorm(t, mean = mean(x), sd = sd.xts(x))
}
dotargs <- list(...)
dotargs$method <- NULL
rm(method)
hist.panel = function(x, ... = NULL) {
par(new = TRUE)
hist(x, col = "white", probability = TRUE, axes = FALSE,
main = "", breaks = "FD")
lines(density(x, na.rm = TRUE), col = "red", lwd = 1)
rug(x)
}
if (histogram)
pairs(x, gap = 0,lower.panel = panel.smooth, upper.panel = panel.cor,
diag.panel = hist.panel)
else pairs(x, gap = 0, lower.panel = panel.smooth, upper.panel = panel.cor)
}
omg i did it myself..
So, here is the edited code:
function (R,L,histogram = TRUE, method = c("pearson", "kendall",
"spearman"), ...)
{
l = checkData(L, method = "zoo")
x = checkData(R, method = "matrix")
if (missing(method))
method = method[1]
panel.cor <- function(x, y, digits = 2, prefix = "", use = "pairwise.complete.obs",
method = "pearson", cex.cor, ...) {
usr <- par("usr")
on.exit(par(usr))
par(usr = c(0, 1, 0, 1))
r <- cor(x, y, use = use, method = method)
txt <- format(c(r, 0.123456789), digits = digits)[1]
txt <- paste(prefix, txt, sep = "")
if (missing(cex.cor))
cex <- 0.8/strwidth(txt)
test <- cor.test(as.numeric(x), as.numeric(y), method = method)
Signif <- symnum(test$p.value, corr = FALSE, na = FALSE,
cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1), symbols = c("***",
"**", "*", ".", " "))
text(0.5, 0.5, txt, cex = cex * (abs(r) + 0.3)/1.6)
text(0.8, 0.8, Signif, cex = 2, col = 2)
}
f <- function(t) {
dnorm(t, mean = mean(x), sd = sd.xts(x))
}
dotargs <- list(...)
dotargs$method <- NULL
rm(method)
hist.panel = function(x, ... = NULL) {
par(new = TRUE)
hist(x, col = "white", probability = TRUE, axes = FALSE,
main = "", breaks = "FD")
lines(density(x, na.rm = TRUE), col = "red", lwd = 1)
rug(x)
}
if (histogram)
pairs(x, bg = c("red","green")[l],gap = 0, pch = 21,lower.panel = panel.smooth, upper.panel = panel.cor,
diag.panel = hist.panel)
else pairs(x, gap = 0, lower.panel = panel.smooth, upper.panel = panel.cor)
}
I am trying to plot a two-dimensional phase portrait in R using the phaseR package. This is an example of what I want to do:
Example that works
library(phaseR)
lotkaVolterra <- function(t, y, parameters) {
x <- y[1]
y <- y[2]
lambda <- parameters[1]
epsilon <- parameters[2]
eta <- parameters[3]
delta <- parameters[4]
dy <- numeric(2)
dy[1] <- lambda*x - epsilon*x*y
dy[2] <- eta*x*y - delta*y
list(dy)
}
then when I plot it I get
lotkaVolterra.flowField <- flowField(lotkaVolterra, x.lim = c(0, 5), y.lim = c(0, 10), parameters = c(2, 1, 3, 2), points = 19, add = FALSE)
grid()
lotkaVolterra.nullclines <- nullclines(lotkaVolterra, x.lim = c(-1, 5), y.lim = c(-1, 10), parameters = c(2, 1, 3, 2), points = 500)
y0 <- matrix(c(1, 2, 2, 2, 3, 4), ncol = 2, nrow = 3, byrow = TRUE)
lotkaVolterra.trajectory <- trajectory(lotkaVolterra, y0 = y0, t.end = 10, parameters = c(2, 1, 3, 2), colour = rep("black", 3))
this is the plot I get:
The problem
When I try to do the same with my equation however the vector space does not appear:
WalpeFun <- function(t, y, parameters) {
x <- y[1]
y <- y[2]
k <- parameters[1]
z <- parameters[2]
w <- parameters[3]
b <- parameters[4]
d <- parameters[5]
v <- parameters[6]
a <- parameters[7]
g <- parameters[8]
l <- parameters[9]
e <- parameters[10]
dy <- numeric(2)
dy[1] <- 2.5*(1-(x/k)^z)+g*l+w*e - b*(x*y/d^2+y^2)
dy[2] <- 2.5 * (1 - (y/x + v)^a)
list(dy)
}
Walpe.flowField <-flowField(WalpeFun, x.lim = c(0, 150), y.lim = c(-1, 50), parameters = c(120.73851, 0.51786, -0.75178, 0.00100, 1.00000, 500, 0.001, 0.01102, 320.995455, 5.582273) , points = 20, add = FALSE)
grid()
Walpe.nullclines <-nullclines(WalpeFun, x.lim = c(0, 150), y.lim = c(-1, 50), parameters = c(120.73851, 0.51786, -0.75178, 0.00100, 1.00000, 500, 0.001, 0.01102, 320.995455, 5.582273))
y0 <- matrix(c(8.2, 2), ncol = 2, nrow = 1, byrow = TRUE)
Walpe.trajectory <-trajectory(WalpeFun, y0 = y0, t.end = 100, parameters = c(120.73851, 0.51786, -0.75178, 0.00100, 1.00000, 500, 0.001, 0.01102, 320.995455, 5.582273),system = "two.dim", colour = "black")
I get this very different plot:
and get the following error:
Error in if ((dx[i, j] != 0) & (dy[i, j] != 0)) { : missing value where TRUE/FALSE needed
I don't understand why the vectors don show, or why the blue nullcline is missing
Mathematically your x.lim range exceeds the domain where the function can have a value. Because your dy[2] expression has x in the denominator of one of its terms, the function blows up at x == 0 and then there will be an NA in the dy[]-matrix that is internal to the function code. (There's a bit of an ambiguity in that your dy-object is a 2 element vector whereas looking at the code, the calculations are being stored in 2d-matrices named dx and dy.)
flowField #look at the code
png()
Walpe.flowField <-flowField(WalpeFun, x.lim = c(0.01, 150), y.lim = c(-1, 50), parameters = c(120.73851, 0.51786, -0.75178, 0.00100, 1.00000, 500, 0.001, 0.01102, 320.995455, 5.582273) , points = 20, add = FALSE, system="two.dim")
Walpe.nullclines <-nullclines(WalpeFun, x.lim = c(0.01, 150), y.lim = c(-1, 50), parameters = c(120.73851, 0.51786, -0.75178, 0.00100, 1.00000, 500, 0.001, 0.01102, 320.995455, 5.582273))
y0 <- matrix(c(8.2, 2), ncol = 2, nrow = 1, byrow = TRUE)
Walpe.trajectory <-trajectory(WalpeFun, y0 = y0, t.end = 100, parameters = c(120.73851, 0.51786, -0.75178, 0.00100, 1.00000, 500, 0.001, 0.01102, 320.995455, 5.582273),system = "two.dim", colour = "black")
dev.off()
I don't know why the nullclines don't appear, but I'm guessing there are features of the function that neither of us understands.
I have challenge in plotting a bivariate raster data in one plot with one legend for both variables. my first layer is a continuous variable ranging between -2 and 2 while the second layer is a categorical variable (in years form 1980 to 2011). I need help in ploting the data as one rastr plot with a color scheme and legend which shows both variables as shown here. I appreciate your help.
r <- raster(ncols=100, nrows=100)
r[] <- runif(ncell(r))
crs(r) <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84"
r1 <- raster(ncols=100, nrows=100)
r1[] <- 1980:2011
crs(r1) <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84"
dta=stack(r,r1)
See ?raster::plot for examples, or do spplot(dta)
I successfully applied the code from the site you mentioned.
kpacks <- c("classInt", 'raster', 'rgdal',
'dismo', 'XML', 'maps', 'sp')
new.packs <- kpacks[!(kpacks %in% installed.packages()[, "Package"])]
if (length(new.packs))
install.packages(new.packs)
lapply(kpacks, require, character.only = T)
remove(kpacks, new.packs)
r <- raster(ncols = 100, nrows = 100)
r[] <- runif(ncell(r))
crs(r) <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84"
r1 <- raster(ncols = 100, nrows = 100)
r1[] <- sample(1980:2011, 10000, replace = T)
crs(r1) <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84"
dta = stack(r, r1)
plot(dta)
colmat <-
function(nquantiles = 10,
upperleft = rgb(0, 150, 235, maxColorValue = 255),
upperright = rgb(130, 0, 80, maxColorValue = 255),
bottomleft = "grey",
bottomright = rgb(255, 230, 15, maxColorValue = 255),
xlab = "x label",
ylab = "y label") {
my.data <- seq(0, 1, .01)
my.class <- classIntervals(my.data, n = nquantiles, style = "quantile")
my.pal.1 <- findColours(my.class, c(upperleft, bottomleft))
my.pal.2 <- findColours(my.class, c(upperright, bottomright))
col.matrix <- matrix(nrow = 101, ncol = 101, NA)
for (i in 1:101) {
my.col <- c(paste(my.pal.1[i]), paste(my.pal.2[i]))
col.matrix[102 - i, ] <- findColours(my.class, my.col)
}
plot(
c(1, 1),
pch = 19,
col = my.pal.1,
cex = 0.5,
xlim = c(0, 1),
ylim = c(0, 1),
frame.plot = F,
xlab = xlab,
ylab = ylab,
cex.lab = 1.3
)
for (i in 1:101) {
col.temp <- col.matrix[i - 1, ]
points(
my.data,
rep((i - 1) / 100, 101),
pch = 15,
col = col.temp,
cex = 1
)
}
seqs <- seq(0, 100, (100 / nquantiles))
seqs[1] <- 1
col.matrix <- col.matrix[c(seqs), c(seqs)]
}
col.matrix <-
colmat(
nquantiles = 10,
upperleft = "blue",
upperright = "yellow",
bottomleft = "green",
bottomright = "red",
xlab = "My x label",
ylab = "My y label"
)
bivariate.map <-
function(rasterx,
rastery,
colormatrix = col.matrix,
nquantiles = 10) {
quanmean <- getValues(rasterx)
temp <- data.frame(quanmean, quantile = rep(NA, length(quanmean)))
brks <-
with(temp, quantile(temp, na.rm = TRUE, probs = c(seq(0, 1, 1 / nquantiles))))
r1 <-
within(
temp,
quantile <-
cut(
quanmean,
breaks = brks,
labels = 2:length(brks),
include.lowest = TRUE
)
)
quantr <- data.frame(r1[, 2])
quanvar <- getValues(rastery)
temp <- data.frame(quanvar, quantile = rep(NA, length(quanvar)))
brks <-
with(temp, quantile(temp, na.rm = TRUE, probs = c(seq(0, 1, 1 / nquantiles))))
r2 <-
within(temp,
quantile <-
cut(
quanvar,
breaks = brks,
labels = 2:length(brks),
include.lowest = TRUE
))
quantr2 <- data.frame(r2[, 2])
as.numeric.factor <- function(x) {
as.numeric(levels(x))[x]
}
col.matrix2 <- colormatrix
cn <- unique(colormatrix)
for (i in 1:length(col.matrix2)) {
ifelse(is.na(col.matrix2[i]),
col.matrix2[i] <- 1,
col.matrix2[i] <- which(col.matrix2[i] == cn)[1])
}
cols <- numeric(length(quantr[, 1]))
for (i in 1:length(quantr[, 1])) {
a <- as.numeric.factor(quantr[i, 1])
b <- as.numeric.factor(quantr2[i, 1])
cols[i] <- as.numeric(col.matrix2[b, a])
}
r <- rasterx
r[1:length(r)] <- cols
return(r)
}
my.colors = colorRampPalette(c("white", "lightblue", "yellow", "orangered", "red"))
plot(
r,
frame.plot = F,
axes = F,
box = F,
add = F,
legend.width = 1,
legend.shrink = 1,
col = my.colors(255)
)
map(interior = T, add = T)
bivmap <- bivariate.map(r, r1, colormatrix = col.matrix, nquantiles = 10)
# Plot the bivariate map:
plot(
bivmap,
frame.plot = F,
axes = F,
box = F,
add = F,
legend = F,
col = as.vector(col.matrix)
)
col.matrix
The R2 obtained from a linear regression is the Pearson correlation coefficient. However, I am wondering if I could get Spearman rank coefficient instead of Pearson in a linear regression.
I would be especially interested to get it using R with the package leaps:
library(leaps)
#Plotting function plot.regsubsets2 <-
function (x, labels = obj$xnames, main = NULL, scale = c("bic",
"Cp", "adjr2", "r2"), col = gray(seq(0, 0.9, length = 10)),
...)
{
obj <- x
lsum <- summary(obj)
par(mar = c(7, 5, 6, 3) + 0.1)
nmodels <- length(lsum$rsq)
np <- obj$np
propscale <- FALSE
sscale <- pmatch(scale[1], c("bic", "Cp", "adjr2", "r2"),
nomatch = 0)
if (sscale == 0)
stop(paste("Unrecognised scale=", scale))
if (propscale)
stop(paste("Proportional scaling only for probabilities"))
yscale <- switch(sscale, lsum$bic, lsum$cp, lsum$adjr2, lsum$rsq)
up <- switch(sscale, -1, -1, 1, 1)
index <- order(yscale * up)
colorscale <- switch(sscale, yscale, yscale, -log(pmax(yscale,
1e-04)), -log(pmax(yscale, 1e-04)))
image(z = t(ifelse(lsum$which[index, ], colorscale[index],
NA + max(colorscale) * 1.5)), xaxt = "n", yaxt = "n",
x = (1:np), y = 1:nmodels, xlab = "", ylab = scale[1],
col = col)
laspar <- par("las")
on.exit(par(las = laspar))
par(las = 2)
axis(1, at = 1:np, labels = labels, ...) # I modified this line
axis(2, at = 1:nmodels, labels = signif(yscale[index], 2))
if (!is.null(main))
title(main = main)
box()
invisible(NULL)
}
#Leap
leaps = regsubets(y~x1+x2+x2, data=mydf, nbest=10)
summary(leaps)
plot.regsubsets2(leaps, scale='r2')
Again, I would like if it possible to screen Spearman instead of Pearson (r2) in the plot.