M. Beausoleil - 1 year ago 97
R Question

# 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
}

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))) {
}
}

my_custom_pca(pca, centered = TRUE)
``````

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(range(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(range(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
}

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(range(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(range(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))) {
}
}
``````

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)`).

Recommended from our users: Dynamic Network Monitoring from WhatsUp Gold from IPSwitch. Free Download