rgraphpca
PCA function with axes crossing 0
I want to plot a PCA and center my graph on my points and have a free set of axes that can plot the vectors. I found a solution to align 2 sets of axes, but I need to set the asp = 1 so that the graph represents equal distances in all directions.
If you copy paste the code below, it's on line 293. I want this asp = 1. But when I add it to my code, the 0-0 line is not aligned... especially when I resize it (see image):
How can I fix this?
s1= rnorm(50,mean = 12)
s2= rnorm(50, mean = 17)
s3= rnorm(50, mean = 100)
library(vegan)
pca=rda(cbind(s1,s2,s3))
pca.scoop=scores(pca, scaling = 2)
# Custom PCA plot ---------------------------------------------------------
my_custom_pca <- function(pca = pca,
scaling = 2,
choices = c(1,2),
zoom=1,
square=FALSE,
square.size = 1,
threshold = 0,
main = 'PCA',
pch = 4,
col.arrow = "grey",
col.label = "red",
size.label = .7,
col.sites = "black",
shape.points = c(17,16,15,19),
size.points = 0.5,
size.sites = .7,
label.the.arrows = TRUE,
vector.names = NULL,
label.the.points = FALSE,
position.text.arrow =1,
centered = FALSE,
# arrow.centered = FALSE,
vector.to.colour.col = 1,
vector.to.colour.pch = 1,
automatic.col = TRUE,
colour.vector = c("#FF3030","#9ACD31","#1D90FF","#FF8001"),
ordiellipse = FALSE,
rev.x = FALSE, # not done yet
rev.y = FALSE, # not done yet
transparent.back = FALSE,
arrows.different.axis = FALSE,
length.arrow = 1,
pca.circle = FALSE,
label.figure = NULL,
png = NULL,
png.w = 9,
png.h = 9,
res.dpi = 300,
pdf = NULL) {
if (!is.null(png)) {
png(file = png,
width = png.w, height = png.h, res = res.dpi, units = "in")
}
if (!is.null(pdf)) {
pdf(file = pdf,
width = 8.5, height = 11)
}
summ.pca = summary(pca, scaling = scaling)
pca.scores1 = scores(pca, scaling = scaling, choices = choices)
prop.exp = round(summ.pca$cont$importance["Proportion Explained",] *100, 2)
pca.axis.name = c(paste("PC1 ", "(", prop.exp[1], "%", ")", sep = ""),
paste("PC2 ", "(", prop.exp[2], "%", ")", sep = ""),
paste("PC3 ", "(", prop.exp[3], "%", ")", sep = ""))[choices]
zoom = zoom
threshold = threshold # this threshold is to put in the graph only the plants that are far away from the center
# (easier to see on the graph), so the one that contributs the most to the variation
"pcacircle" <- function (pca)
{
# Draws a circle of equilibrium contribution on a PCA plot
# generated from a vegan analysis.
# vegan uses special constants for its outputs, hence
# the 'const' value below.
eigenv <- pca$CA$eig
p <- length(eigenv)
n <- nrow(pca$CA$u)
tot <- sum(eigenv)
const <- ((n - 1) * tot)^0.25
radius <- (2/p)^0.5
radius <- radius * const
symbols(0, 0, circles=radius, inches=FALSE, add=TRUE, fg=2)
}
line2user <- function(line, side) {
lh <- par('cin')[2] * par('cex') * par('lheight') *.5
x_off <- diff(grconvertX(c(0, lh), 'inches', 'npc'))
y_off <- diff(grconvertY(c(0, lh), 'inches', 'npc'))
switch(side,
`1` = grconvertY(-line * y_off, 'npc', 'user'),
`2` = grconvertX(-line * x_off, 'npc', 'user'),
`3` = grconvertY(1 + line * y_off, 'npc', 'user'),
`4` = grconvertX(1 + line * x_off, 'npc', 'user'),
stop("Side must be 1, 2, 3, or 4", call.=FALSE))
}
addfiglab <- function(lab, xl = par()$mar[2], yl = par()$mar[3]) {
text(x = line2user(xl, 2), y = line2user(yl, 3),
lab, xpd = NA, font = 2, cex = 1.5, adj = c(0, 1))
}
# costum alignment of the axes
new_lim <- function(a, type = 1) {
newdata_ratio <- NULL
i <- type * 2 - 1
old_lim <- par("usr")[i:(i+1)] + c(diff(par("usr")[i:(i+1)]) * 0.04 / 1.08,
diff(par("usr")[i:(i+1)]) * -0.04 / 1.08)
old_ratio <- old_lim[1] / old_lim[2]
newdata_ratio <- if (max(a) <= 0) -1.0e+6 else min(a) / max(a)
if (old_ratio >= newdata_ratio ) {
new_min <- min(a)
new_max <- min(a) / old_ratio
} else {
new_min <- max(a) * old_ratio
new_max <- max(a)
}
c(new_min, new_max)
}
# Draw the PCA with plot.cca
myccaplot <- function (x, choices = c(1, 2), display = c("sp", "wa", "cn"),
scaling = "species", type, xlim, ylim, const, correlation = FALSE,
hill = FALSE, ...) {
TYPES <- c("text", "points", "none")
g <- scores(x, choices, display, scaling, const, correlation = correlation,
hill = hill)
if (length(g) == 0 || all(is.na(g)))
stop("nothing to plot: requested scores do not exist")
if (!is.list(g))
g <- list(default = g)
for (i in seq_along(g)) {
if (length(dim(g[[i]])) > 1)
rownames(g[[i]]) <- rownames(g[[i]], do.NULL = FALSE,
prefix = substr(names(g)[i], 1, 3))
}
if (!is.null(g$centroids)) {
if (is.null(g$biplot))
g$biplot <- scores(x, choices, "bp", scaling)
if (!is.na(g$centroids)[1]) {
bipnam <- rownames(g$biplot)
cntnam <- rownames(g$centroids)
g$biplot <- g$biplot[!(bipnam %in% cntnam), , drop = FALSE]
if (nrow(g$biplot) == 0)
g$biplot <- NULL
}
}
if (missing(type)) {
nitlimit <- 80
nit <- max(nrow(g$spe), nrow(g$sit), nrow(g$con), nrow(g$def))
if (nit > nitlimit)
type <- "points"
else type <- "text"
}
else type <- match.arg(type, TYPES)
if (length(choices) == 1) {
if (length(g) == 1)
pl <- linestack(g[[1]], ...)
else {
hasSpec <- names(g)[1] == "species"
ylim <- range(c(g[[1]], g[[2]]), na.rm = TRUE)
pl <- linestack(g[[1]], ylim = ylim, side = ifelse(hasSpec,
"left", "right"), ...)
linestack(g[[2]], ylim = ylim, side = ifelse(hasSpec,
"right", "left"), add = TRUE, ...)
}
return(invisible(pl))
}
if (missing(xlim)) {
xlim <- range(g$species[, 1], g$sites[, 1], g$constraints[,
1], g$biplot[, 1], if (length(g$centroids) > 0 &&
is.na(g$centroids)) NA else g$centroids[, 1], g$default[,
1], na.rm = TRUE)
}
if (!any(is.finite(xlim)))
stop("no finite scores to plot")
if (missing(ylim)) {
ylim <- range(g$species[, 2], g$sites[, 2], g$constraints[,
2], g$biplot[, 2], if (length(g$centroids) > 0 &&
is.na(g$centroids)) NA else g$centroids[, 2], g$default[,
2], na.rm = TRUE)
}
if(rev.x) {
xlim=rev(xlim)
}
if(rev.y) {
ylim=rev(ylim)
}
plot(g[[1]], xlim = xlim, ylim = ylim, type = "n",
asp = 1, # I had to remove this so that new_lim work.
...)
# abline(h = 0, lty = 3) # removed
# abline(v = 0, lty = 3) # removed
if (!is.null(g$species)) {
if (type == "text")
text(g$species, rownames(g$species), col = "red",
cex = 0.7)
else if (type == "points")
points(g$species, pch = "+", col = "red", cex = 0.7)
}
if (!is.null(g$sites)) {
if (type == "text")
text(g$sites, rownames(g$sites), cex = 0.7)
else if (type == "points")
points(g$sites, pch = 1, cex = 0.7)
}
if (!is.null(g$constraints)) {
if (type == "text")
text(g$constraints, rownames(g$constraints), cex = 0.7,
col = "darkgreen")
else if (type == "points")
points(g$constraints, pch = 2, cex = 0.7, col = "darkgreen")
}
if (!is.null(g$biplot) && nrow(g$biplot) > 0 && type != "none") {
if (length(display) > 1) {
mul <- ordiArrowMul(g$biplot)
}
else mul <- 1
attr(g$biplot, "arrow.mul") <- mul
arrows(0, 0, mul * g$biplot[, 1], mul * g$biplot[, 2],
length = 0.05, col = "blue")
biplabs <- ordiArrowTextXY(mul * g$biplot, rownames(g$biplot))
text(biplabs, rownames(g$biplot), col = "blue")
axis(3, at = c(-mul, 0, mul), labels = rep("", 3), col = "blue")
axis(4, at = c(-mul, 0, mul), labels = c(-1, 0, 1), col = "blue")
}
if (!is.null(g$centroids) && !is.na(g$centroids) && type !=
"none") {
if (type == "text")
text(g$centroids, rownames(g$centroids), col = "blue")
else if (type == "points")
points(g$centroids, pch = "x", col = "blue")
}
if (!is.null(g$default) && type != "none") {
if (type == "text")
text(g$default, rownames(g$default), cex = 0.7)
else if (type == "points")
points(g$default, pch = 1, cex = 0.7)
}
class(g) <- "ordiplot"
invisible(g)
}
align <- function(x) {
c(-max(c(-min(x),max(x))),max(c(-min(x),max(x))))
}
if (transparent.back) {
par(bg=NA)
}
if (centered) {
par(mar = c(6,6,6,6))
x0 = c(min(pca.scores1$sites[,1])*zoom,max(pca.scores1$sites[,1])*zoom)
y0 = c(min(pca.scores1$sites[,2])*zoom,max(pca.scores1$sites[,2])*zoom)
myccaplot(pca,
type = c("n"),
main = main,
scaling = scaling,
choices = choices,
bty = "o",
xlab = pca.axis.name[1], ylab = pca.axis.name[2],
xlim = x0, # pmx,
ylim = y0, # pmy,
pch=4,
axes = FALSE)
axis(1) ### (2)
axis(2) ### (2)
box() ### (2)
points(pca.scores1$sites,
col=colour.vector[(as.numeric(vector.to.colour.col))], # c("grey","blue") # palette()
pch=shape.points[(as.numeric(vector.to.colour.pch))], # red = AB, green = EG, light blue = magnirostris, purple = scandens
cex = size.points)
if (label.the.points) {
text(x = summ.pca$sites[,1],
y = summ.pca$sites[,2],
labels = row.names(summ.pca$sites[,]),
cex = size.sites,
col = col.sites,
pos = 1)
}
if (ordiellipse) {
ordiellipse(pca.scores1,vector.to.colour.col,conf=0.95)
}
par(new=TRUE)
x1 = c(min(pca.scores1$species[,1]),max(pca.scores1$species[,1]))
y1 = c(min(pca.scores1$species[,2]),max(pca.scores1$species[,2]))
plot(x = x1,
y = y1,
xlim = new_lim(x1),
ylim = new_lim(y1, 2), # w: 461, h 661 pixels works...
asp = 1, #Not working with new_lim
xlab = pca.axis.name[1],
ylab = pca.axis.name[2],
type = "n",
main= "",
axes = F, ann = F,
bty = "n")
axis(3, col="red",col.axis="red",
cex.axis = 1)
axis(4, col="red",col.axis="red",
cex.axis = 1)
if (pca.circle == TRUE & scaling == 1){
pcacircle(pca)
}
abline(h=0,v=0, lty = 3)
if (rev.x) {
pca.scores1$species[,1] = -1*(pca.scores1$species[,1]*length.arrow)
}
if (rev.y) {
pca.scores1$species[,2] = -1*(pca.scores1$species[,2]*length.arrow)
}
arrows(0,0,
pca.scores1$species[,1]*length.arrow,
pca.scores1$species[,2]*length.arrow,
length = .1,
code = 2,
col = col.arrow)
} else {
plot(pca,
choices = choices,
type = c("n"),
xlab = pca.axis.name[1],
ylab = pca.axis.name[2],
main= main,
scaling = scaling,
pch=4)
points(pca.scores1$sites,
col=colour.vector[(as.numeric(vector.to.colour.col))], # c("grey","blue") # palette()
pch=shape.points[(as.numeric(vector.to.colour.pch))], # red = AB, green = EG, light blue = magnirostris, purple = scandens
cex = size.points)
if (rev.x) {
summ.pca$species[,1] = rev(summ.pca$species[,1])
}
if (rev.y) {
summ.pca$species[,1] = rev(summ.pca$species[,1])
}
arrows(0,0,
summ.pca$species[,choices[1]],
summ.pca$species[,choices[2]],
length = .1,
code = 2,
col = col.arrow)
if (pca.circle == TRUE & scaling == 1){
pcacircle(pca)
}
if (ordiellipse) {
ordiellipse(pca.scores1,vector.to.colour.col,conf=0.95)
}
}
if (rev.x) {
summ.pca$species[,1] = -1*(summ.pca$species[,1])
}
if (rev.y) {
summ.pca$species[,2] = -1*(summ.pca$species[,2])
}
if (!(length(small))) {
if (label.the.arrows) {
text(x = summ.pca$species[,choices[1]],
y = summ.pca$species[,choices[2]],
labels = row.names(summ.pca$species[,]),
cex = size.label,
col = col.label)
} else {
text(x = summ.pca$species[,choices[1]],
y = summ.pca$species[,choices[2]],
labels = vector.names,
pos = position.text.arrow,
cex = size.label,
col = col.label)
}
} else {
if (label.the.arrows) {
text(x = summ.pca$species[-small,choices[1]],
y = summ.pca$species[-small,choices[2]],
labels = row.names(summ.pca$species[-small,]),
cex = size.label,
col = col.label)
} else {
text(x = summ.pca$species[,choices[1]],
y = summ.pca$species[,choices[2]],
labels = vector.names,
pos = position.text.arrow,
cex = size.label,
col = col.label)
}
}
if (rev.x) {
summ.pca$sites[,1] = -1*(summ.pca$sites[,1])
}
if (rev.y) {
summ.pca$sites[,2] = -1*(summ.pca$sites[,2])
}
if (label.the.points & !centered) {
text(x = summ.pca$sites[,1],
y = summ.pca$sites[,2],
labels = row.names(summ.pca$sites[,]),
cex = size.sites,
col = col.sites,
pos = 1)
}
if (square) {
abline(h = c(-square.size,square.size),
v = c(-square.size,square.size),
lty = 3)
}
if (!is.null(png)|!is.null(pdf)) {
dev.off()
}
if (!(!length(label.figure))) {
addfiglab(label.figure)
}
}
my_custom_pca(pca, centered = TRUE)
Solution
I made new_xylim() that partly solves your problem. This function calculates second graph's xlim() and ylim() to align 2 sets of axes and set the same scale of 2nd x and y. Please use it instead of new_lim().
When you use asp=1 at both first and second graph and resize an output, I think there are four patterns (dependence on data): (1) change of axis(1) and axis(3), (2) axis(2) and axis(4), (3) axis(1) but not axis(3), or the reverse, (4) axis(2) but not axis(4), or the reverse. When (3) or (4), it is difficult to realize what you want, so please change device size before output instead of resizing.
only new_xylim();
new_xylim <- function(x2, y2) {
# new_lim2() calculates xlim or ylim in view of only alignment.
new_lim2 <- function(a, type = 1, ratio = FALSE) {
new_ratio <- NULL # type=1 is for xlim, 2 is for ylim.
i <- type * 2 - 1
old_lim <- par("usr")[i:(i+1)] + c(diff(par("usr")[i:(i+1)]) * 0.04 / 1.08,
diff(par("usr")[i:(i+1)]) * -0.04 / 1.08)
old_ratio <- diff(old_lim) / (-1 * old_lim[1])
new_ratio <- if (min(a) >= 0) 1.0e+6 else diff(range(a)) / (-1 * min(a))
if (old_ratio >= new_ratio) {
new_min <- min(a)
new_max <- abs(min(a)) * (old_ratio - 1)
} else {
new_min <- abs(max(a)) / (old_ratio - 1) * -1
new_max <- max(a)
}
if (ratio) return(old_ratio) else return(c(new_min, new_max))
}
temp_x <- new_lim2(x2, type=1) # calculation of needing range
temp_y <- new_lim2(y2, type=2)
if (par("pin")[1] / diff(temp_x) >= par("pin")[2] / diff(temp_y)) {
# logical judgment of which range is expanded under the same scale
new_ylim <- temp_y # the one range isn't expanded.
new_xdiff <- par("pin")[1] * diff(new_ylim) / par("pin")[2] # calculation of the another expanded range
old_xratio <- new_lim2(x2, type = 1, ratio = TRUE) # information about zero position
new_xlim <- c(-1 * new_xdiff / old_xratio, new_xdiff - new_xdiff / old_xratio) # calculation of _lim by the zero position and the expanded range
} else {
new_xlim <- temp_x
new_ydiff <- par("pin")[2] * diff(new_xlim) / par("pin")[1]
old_yratio <- new_lim2(y2, type=2, ratio = TRUE)
new_ylim <- c(-1 * new_ydiff / old_yratio, new_ydiff - new_ydiff / old_yratio)
}
return(list(new_xlim, new_ylim))
}
an example of new_xylim();
x2 <- -1:3
y2 <- seq(-100, 30, length=5)
plot(-5:5, -1:9, ann=F, asp=1)
par(new=T)
plot(x2, y2, xlim=new_xylim(x2, y2)[[1]], ylim=new_xylim(x2, y2)[[2]], ann=F, axes=F, asp=1)
axis(3); axis(4); abline(h=0); abline(v=0) # if you don't resize, second graph's asp=1 is unnecessary.
modified your function() (I also added argument small = NULL to suppress error);
# Custom PCA plot ---------------------------------------------------------
my_custom_pca2 <- function(pca = pca,
scaling = 2,
choices = c(1,2),
zoom=1,
square=FALSE,
square.size = 1,
threshold = 0,
main = 'PCA',
pch = 4,
col.arrow = "grey",
col.label = "red",
size.label = .7,
col.sites = "black",
shape.points = c(17,16,15,19),
size.points = 0.5,
size.sites = .7,
label.the.arrows = TRUE,
vector.names = NULL,
label.the.points = FALSE,
position.text.arrow =1,
centered = FALSE,
# arrow.centered = FALSE,
vector.to.colour.col = 1,
vector.to.colour.pch = 1,
automatic.col = TRUE,
colour.vector = c("#FF3030","#9ACD31","#1D90FF","#FF8001"),
ordiellipse = FALSE,
rev.x = FALSE, # not done yet
rev.y = FALSE, # not done yet
transparent.back = FALSE,
arrows.different.axis = FALSE,
length.arrow = 1,
pca.circle = FALSE,
label.figure = NULL,
png = NULL,
png.w = 9,
png.h = 9,
res.dpi = 300,
pdf = NULL,
small = NULL) { ### modified
if (!is.null(png)) {
png(file = png,
width = png.w, height = png.h, res = res.dpi, units = "in")
}
if (!is.null(pdf)) {
pdf(file = pdf,
width = 8.5, height = 11)
}
summ.pca = summary(pca, scaling = scaling)
pca.scores1 = scores(pca, scaling = scaling, choices = choices)
prop.exp = round(summ.pca$cont$importance["Proportion Explained",] *100, 2)
pca.axis.name = c(paste("PC1 ", "(", prop.exp[1], "%", ")", sep = ""),
paste("PC2 ", "(", prop.exp[2], "%", ")", sep = ""),
paste("PC3 ", "(", prop.exp[3], "%", ")", sep = ""))[choices]
zoom = zoom
threshold = threshold # this threshold is to put in the graph only the plants that are far away from the center
# (easier to see on the graph), so the one that contributs the most to the variation
"pcacircle" <- function (pca)
{
# Draws a circle of equilibrium contribution on a PCA plot
# generated from a vegan analysis.
# vegan uses special constants for its outputs, hence
# the 'const' value below.
eigenv <- pca$CA$eig
p <- length(eigenv)
n <- nrow(pca$CA$u)
tot <- sum(eigenv)
const <- ((n - 1) * tot)^0.25
radius <- (2/p)^0.5
radius <- radius * const
symbols(0, 0, circles=radius, inches=FALSE, add=TRUE, fg=2)
}
line2user <- function(line, side) {
lh <- par('cin')[2] * par('cex') * par('lheight') *.5
x_off <- diff(grconvertX(c(0, lh), 'inches', 'npc'))
y_off <- diff(grconvertY(c(0, lh), 'inches', 'npc'))
switch(side,
`1` = grconvertY(-line * y_off, 'npc', 'user'),
`2` = grconvertX(-line * x_off, 'npc', 'user'),
`3` = grconvertY(1 + line * y_off, 'npc', 'user'),
`4` = grconvertX(1 + line * x_off, 'npc', 'user'),
stop("Side must be 1, 2, 3, or 4", call.=FALSE))
}
addfiglab <- function(lab, xl = par()$mar[2], yl = par()$mar[3]) {
text(x = line2user(xl, 2), y = line2user(yl, 3),
lab, xpd = NA, font = 2, cex = 1.5, adj = c(0, 1))
}
# costum alignment of the axes
new_xylim <- function(x2, y2) { ### modified
new_lim2 <- function(a, type = 1, ratio = FALSE) {
new_ratio <- NULL
i <- type * 2 - 1
old_lim <- par("usr")[i:(i+1)] + c(diff(par("usr")[i:(i+1)]) * 0.04 / 1.08,
diff(par("usr")[i:(i+1)]) * -0.04 / 1.08)
old_ratio <- diff(old_lim) / (-1 * old_lim[1])
new_ratio <- if (min(a) >= 0) 1.0e+6 else diff(range(a)) / (-1 * min(a))
if (old_ratio >= new_ratio) {
new_min <- min(a)
new_max <- abs(min(a)) * (old_ratio - 1)
} else {
new_min <- abs(max(a)) / (old_ratio - 1) * -1
new_max <- max(a)
}
if (ratio) return(old_ratio) else return(c(new_min, new_max))
}
temp_x <- new_lim2(x2, type=1)
temp_y <- new_lim2(y2, type=2)
if (par("pin")[1] / diff(temp_x) >= par("pin")[2] / diff(temp_y)) {
new_ylim <- temp_y
new_xdiff <- par("pin")[1] * diff(new_ylim) / par("pin")[2]
old_xratio <- new_lim2(x2, type = 1, ratio = TRUE)
new_xlim <- c(-1 * new_xdiff / old_xratio, new_xdiff - new_xdiff / old_xratio)
} else {
new_xlim <- temp_x
new_ydiff <- par("pin")[2] * diff(new_xlim) / par("pin")[1]
old_yratio <- new_lim2(y2, type=2, ratio = TRUE)
new_ylim <- c(-1 * new_ydiff / old_yratio, new_ydiff - new_ydiff / old_yratio)
}
return(list(new_xlim, new_ylim))
}
# Draw the PCA with plot.cca
myccaplot <- function (x, choices = c(1, 2), display = c("sp", "wa", "cn"),
scaling = "species", type, xlim, ylim, const, correlation = FALSE,
hill = FALSE, ...) {
TYPES <- c("text", "points", "none")
g <- scores(x, choices, display, scaling, const, correlation = correlation,
hill = hill)
if (length(g) == 0 || all(is.na(g)))
stop("nothing to plot: requested scores do not exist")
if (!is.list(g))
g <- list(default = g)
for (i in seq_along(g)) {
if (length(dim(g[[i]])) > 1)
rownames(g[[i]]) <- rownames(g[[i]], do.NULL = FALSE,
prefix = substr(names(g)[i], 1, 3))
}
if (!is.null(g$centroids)) {
if (is.null(g$biplot))
g$biplot <- scores(x, choices, "bp", scaling)
if (!is.na(g$centroids)[1]) {
bipnam <- rownames(g$biplot)
cntnam <- rownames(g$centroids)
g$biplot <- g$biplot[!(bipnam %in% cntnam), , drop = FALSE]
if (nrow(g$biplot) == 0)
g$biplot <- NULL
}
}
if (missing(type)) {
nitlimit <- 80
nit <- max(nrow(g$spe), nrow(g$sit), nrow(g$con), nrow(g$def))
if (nit > nitlimit)
type <- "points"
else type <- "text"
}
else type <- match.arg(type, TYPES)
if (length(choices) == 1) {
if (length(g) == 1)
pl <- linestack(g[[1]], ...)
else {
hasSpec <- names(g)[1] == "species"
ylim <- range(c(g[[1]], g[[2]]), na.rm = TRUE)
pl <- linestack(g[[1]], ylim = ylim, side = ifelse(hasSpec,
"left", "right"), ...)
linestack(g[[2]], ylim = ylim, side = ifelse(hasSpec,
"right", "left"), add = TRUE, ...)
}
return(invisible(pl))
}
if (missing(xlim)) {
xlim <- range(g$species[, 1], g$sites[, 1], g$constraints[,
1], g$biplot[, 1], if (length(g$centroids) > 0 &&
is.na(g$centroids)) NA else g$centroids[, 1], g$default[,
1], na.rm = TRUE)
}
if (!any(is.finite(xlim)))
stop("no finite scores to plot")
if (missing(ylim)) {
ylim <- range(g$species[, 2], g$sites[, 2], g$constraints[,
2], g$biplot[, 2], if (length(g$centroids) > 0 &&
is.na(g$centroids)) NA else g$centroids[, 2], g$default[,
2], na.rm = TRUE)
}
if(rev.x) {
xlim=rev(xlim)
}
if(rev.y) {
ylim=rev(ylim)
}
plot(g[[1]], xlim = xlim, ylim = ylim, type = "n",
asp = 1, # I had to remove this so that new_lim work.
...)
# abline(h = 0, lty = 3) # removed
# abline(v = 0, lty = 3) # removed
if (!is.null(g$species)) {
if (type == "text")
text(g$species, rownames(g$species), col = "red",
cex = 0.7)
else if (type == "points")
points(g$species, pch = "+", col = "red", cex = 0.7)
}
if (!is.null(g$sites)) {
if (type == "text")
text(g$sites, rownames(g$sites), cex = 0.7)
else if (type == "points")
points(g$sites, pch = 1, cex = 0.7)
}
if (!is.null(g$constraints)) {
if (type == "text")
text(g$constraints, rownames(g$constraints), cex = 0.7,
col = "darkgreen")
else if (type == "points")
points(g$constraints, pch = 2, cex = 0.7, col = "darkgreen")
}
if (!is.null(g$biplot) && nrow(g$biplot) > 0 && type != "none") {
if (length(display) > 1) {
mul <- ordiArrowMul(g$biplot)
}
else mul <- 1
attr(g$biplot, "arrow.mul") <- mul
arrows(0, 0, mul * g$biplot[, 1], mul * g$biplot[, 2],
length = 0.05, col = "blue")
biplabs <- ordiArrowTextXY(mul * g$biplot, rownames(g$biplot))
text(biplabs, rownames(g$biplot), col = "blue")
axis(3, at = c(-mul, 0, mul), labels = rep("", 3), col = "blue")
axis(4, at = c(-mul, 0, mul), labels = c(-1, 0, 1), col = "blue")
}
if (!is.null(g$centroids) && !is.na(g$centroids) && type !=
"none") {
if (type == "text")
text(g$centroids, rownames(g$centroids), col = "blue")
else if (type == "points")
points(g$centroids, pch = "x", col = "blue")
}
if (!is.null(g$default) && type != "none") {
if (type == "text")
text(g$default, rownames(g$default), cex = 0.7)
else if (type == "points")
points(g$default, pch = 1, cex = 0.7)
}
class(g) <- "ordiplot"
invisible(g)
}
align <- function(x) {
c(-max(c(-min(x),max(x))),max(c(-min(x),max(x))))
}
if (transparent.back) {
par(bg=NA)
}
if (centered) {
par(mar = c(6,6,6,6))
x0 = c(min(pca.scores1$sites[,1])*zoom,max(pca.scores1$sites[,1])*zoom)
y0 = c(min(pca.scores1$sites[,2])*zoom,max(pca.scores1$sites[,2])*zoom)
myccaplot(pca,
type = c("n"),
main = main,
scaling = scaling,
choices = choices,
bty = "o",
xlab = pca.axis.name[1], ylab = pca.axis.name[2],
xlim = x0, # pmx,
ylim = y0, # pmy,
pch=4,
axes = FALSE)
axis(1) ### (2)
axis(2) ### (2)
box() ### (2)
points(pca.scores1$sites,
col=colour.vector[(as.numeric(vector.to.colour.col))], # c("grey","blue") # palette()
pch=shape.points[(as.numeric(vector.to.colour.pch))], # red = AB, green = EG, light blue = magnirostris, purple = scandens
cex = size.points)
if (label.the.points) {
text(x = summ.pca$sites[,1],
y = summ.pca$sites[,2],
labels = row.names(summ.pca$sites[,]),
cex = size.sites,
col = col.sites,
pos = 1)
}
if (ordiellipse) {
ordiellipse(pca.scores1,vector.to.colour.col,conf=0.95)
}
par(new=TRUE)
x1 = c(min(pca.scores1$species[,1]),max(pca.scores1$species[,1]))
y1 = c(min(pca.scores1$species[,2]),max(pca.scores1$species[,2]))
plot(x = x1,
y = y1,
xlim = new_xylim(x1, y1)[[1]], ### modified
ylim = new_xylim(x1, y1)[[2]], ### modified
asp = 1,
xlab = pca.axis.name[1],
ylab = pca.axis.name[2],
type = "n",
main= "",
axes = F, ann = F,
bty = "n")
axis(3, col="red",col.axis="red",
cex.axis = 1)
axis(4, col="red",col.axis="red",
cex.axis = 1)
if (pca.circle == TRUE & scaling == 1){
pcacircle(pca)
}
abline(h=0,v=0, lty = 3)
if (rev.x) {
pca.scores1$species[,1] = -1*(pca.scores1$species[,1]*length.arrow)
}
if (rev.y) {
pca.scores1$species[,2] = -1*(pca.scores1$species[,2]*length.arrow)
}
arrows(0,0,
pca.scores1$species[,1]*length.arrow,
pca.scores1$species[,2]*length.arrow,
length = .1,
code = 2,
col = col.arrow)
} else {
plot(pca,
choices = choices,
type = c("n"),
xlab = pca.axis.name[1],
ylab = pca.axis.name[2],
main= main,
scaling = scaling,
pch=4)
points(pca.scores1$sites,
col=colour.vector[(as.numeric(vector.to.colour.col))], # c("grey","blue") # palette()
pch=shape.points[(as.numeric(vector.to.colour.pch))], # red = AB, green = EG, light blue = magnirostris, purple = scandens
cex = size.points)
if (rev.x) {
summ.pca$species[,1] = rev(summ.pca$species[,1])
}
if (rev.y) {
summ.pca$species[,1] = rev(summ.pca$species[,1])
}
arrows(0,0,
summ.pca$species[,choices[1]],
summ.pca$species[,choices[2]],
length = .1,
code = 2,
col = col.arrow)
if (pca.circle == TRUE & scaling == 1){
pcacircle(pca)
}
if (ordiellipse) {
ordiellipse(pca.scores1,vector.to.colour.col,conf=0.95)
}
}
if (rev.x) {
summ.pca$species[,1] = -1*(summ.pca$species[,1])
}
if (rev.y) {
summ.pca$species[,2] = -1*(summ.pca$species[,2])
}
if (!(length(small))) {
if (label.the.arrows) {
text(x = summ.pca$species[,choices[1]],
y = summ.pca$species[,choices[2]],
labels = row.names(summ.pca$species[,]),
cex = size.label,
col = col.label)
} else {
text(x = summ.pca$species[,choices[1]],
y = summ.pca$species[,choices[2]],
labels = vector.names,
pos = position.text.arrow,
cex = size.label,
col = col.label)
}
} else {
if (label.the.arrows) {
text(x = summ.pca$species[-small,choices[1]],
y = summ.pca$species[-small,choices[2]],
labels = row.names(summ.pca$species[-small,]),
cex = size.label,
col = col.label)
} else {
text(x = summ.pca$species[,choices[1]],
y = summ.pca$species[,choices[2]],
labels = vector.names,
pos = position.text.arrow,
cex = size.label,
col = col.label)
}
}
if (rev.x) {
summ.pca$sites[,1] = -1*(summ.pca$sites[,1])
}
if (rev.y) {
summ.pca$sites[,2] = -1*(summ.pca$sites[,2])
}
if (label.the.points & !centered) {
text(x = summ.pca$sites[,1],
y = summ.pca$sites[,2],
labels = row.names(summ.pca$sites[,]),
cex = size.sites,
col = col.sites,
pos = 1)
}
if (square) {
abline(h = c(-square.size,square.size),
v = c(-square.size,square.size),
lty = 3)
}
if (!is.null(png)|!is.null(pdf)) {
dev.off()
}
if (!(!length(label.figure))) {
addfiglab(label.figure)
}
}
using it;
set.seed(1); s1= rnorm(50,mean = 12)
set.seed(10); s2= rnorm(50, mean = 17)
set.seed(100); s3= rnorm(50, mean = 100)
library(vegan)
pca=rda(cbind(s1,s2,s3))
pca.scoop=scores(pca, scaling = 2)
my_custom_pca2(pca, centered = TRUE)
par("pin")[1]/diff(par("usr")[1:2])
par("pin")[2]/diff(par("usr")[3:4]) # the same
In this case on my environment (640 x 500), I can resize the width larger and/or the height smaller (change of axis(1) and axis(3)) but can't the width smaller and/or the height larger (change of axis(1) but not axis(3)).
- barplot multiple aggregation
- Start a PowerShell script in R via system2()
- plot from sankeyNetwork in networkD3 does not show output (issue is not number of unique nodes)
- "Target position can only be set for new windows" in chromote in R
- Extract the correct data type in a PDF table
- Time conversion in R
- Comparing the values of a certain number previous rows with the current row
- Run a single test function in R's testthat
- rpart package installation in R
- An efficient way to assign value based on a min-max range and category
- Change output of the `purrr::map` function
- osmdata_sf returns failed to perform HTTP request curl::curl_fetch_memory() error in R?
- Comparing nls() to nls2() - what am I doing wrong
- How to add "variables grid" below ggplot
- How can I use predefined code snippets outside of code chunks in Quarto within RStudio/Posit?
- Wrap text for collapse rows in KableExtra for a long table in R
- Implementation of Breusch-Pagan test for random effects in plm with unbalanced panels
- Finding a value of a dataset in different ones
- Replicate matrix
- Unexpected results after converting raster data from geographic to projected coordinate system using the terra package
- How to remove rows by condition in R?
- How do I add an alias for magrittr pipe from R in vscode
- Package ‘neuralnet’ in R, rectified linear unit (ReLU) activation function?
- Reticulate with pywin32, a dependency of xlwings, not found when sourcing python script from R
- Sub-subtitle in a graph made with `ggplot2`
- How can I execute a statement and ignore warnings with tryCatch?
- Enumerate events where n consecutive values are not NA
- Serialize/deserialize a column with R and DuckDB
- How can I structure my sapflow data to analyze using "TREX" package in R?
- Putting multiple plots on the same page in R?