script - R: agregar ejes calibrados a PCA biplot en ggplot2

script pca r

Question

Estoy trabajando en un paquete de ordenación usando ggplot2 . En este momento estoy construyendo biplots de la manera tradicional, con las cargas representadas con flechas. Sin embargo, también me interesaría utilizar los ejes calibrados y representar los ejes de carga como líneas a través del origen, y las etiquetas de carga se muestran fuera de la región de la parcela. En base R esto se implementa en

library(OpenRepGrid)
biplot2d(boeker)

Pero estoy buscando una solución ggplot2 . ¿Alguien tendría alguna idea de cómo lograr algo como esto en ggplot2 ? Añadir los nombres de las variables fuera de la región de la trama podría hacerse como aquí , supongo, pero ¿cómo se podrían trazar los segmentos de línea fuera de la región de la trama?

Actualmente lo que tengo es

install.packages("devtools")
library(devtools)
install_github("fawda123/ggord")
library(ggord)
data(iris)
ord <- prcomp(iris[,1:4],scale=TRUE)
ggord(ord, iris$Species)

Las cargas están en ord$rotation

                    PC1         PC2        PC3        PC4
Sepal.Length  0.5210659 -0.37741762  0.7195664  0.2612863
Sepal.Width  -0.2693474 -0.92329566 -0.2443818 -0.1235096
Petal.Length  0.5804131 -0.02449161 -0.1421264 -0.8014492
Petal.Width   0.5648565 -0.06694199 -0.6342727  0.5235971

¿Cómo podría agregar las líneas a través del origen, las marcas externas y las etiquetas fuera de la región del eje (incluido de manera brillante el jittering frío que se aplica arriba para las etiquetas superpuestas)?

NB No quiero desactivar el recorte, ya que algunos de los elementos de mi trama a veces pueden salir del cuadro delimitador

EDITAR: Alguien más aparentemente hizo una pregunta similar antes , aunque la pregunta todavía no tiene una respuesta. Señala que para hacer algo como esto en la base R (aunque de una manera fea) se puede hacer, por ejemplo

plot(-1:1, -1:1, asp = 1, type = "n", xaxt = "n", yaxt = "n", xlab = "", ylab = "")
abline(a = 0, b = -0.75)
abline(a = 0, b = 0.25)
abline(a = 0, b = 2)
mtext("V1", side = 4, at = -0.75*par("usr")[2])
mtext("V2", side = 2, at = 0.25*par("usr")[1])
mtext("V3", side = 3, at = par("usr")[4]/2)

Un ejemplo mínimo viable en ggplot2 sería

library(ggplot2)
df <- data.frame(x = -1:1, y = -1:1)
dfLabs <- data.frame(x = c(1, -1, 1/2), y = c(-0.75, -0.25, 1), labels = paste0("V", 1:3))
p <- ggplot(data = df, aes(x = x, y = y)) +  geom_blank() +
  geom_abline(intercept = rep(0, 3), slope = c(-0.75, 0.25, 2)) +
  theme_bw() + coord_cartesian(xlim = c(-1, 1), ylim = c(-1, 1)) +
  theme(axis.title = element_blank(), axis.text = element_blank(), axis.ticks = element_blank(),
        panel.grid = element_blank())
p + geom_text(data = dfLabs, mapping = aes(label = labels))

pero como no se puede ver la suerte con las etiquetas, estoy buscando una solución que no requiera una para desactivar el recorte.

EDIT2: un poco de una pregunta relacionada es ¿cómo podría agregar cortes / marcas y marcas personalizadas, digamos en rojo, en la parte superior del eje X y a la derecha del eje Y, para mostrar el sistema de coordenadas de las cargas factoriales? (En caso de que lo escalara en relación con las puntuaciones de los factores para aclarar las flechas, normalmente combinadas con un círculo unitario)

Answer 1

¿Qué pasa con esto?

Usa el siguiente código. Si desea que las etiquetas también estén arriba y a la derecha, eche un vistazo a: http://rpubs.com/kohske/dual_axis_in_ggplot2

require(ggplot2)

data(iris)
ord <- prcomp(iris[,1:4],scale=TRUE)

slope <- ord$rotation[,2]/ord$rotation[,1]

p <- ggplot() + 
  geom_point(data = as.data.frame(ord$x), aes(x = PC1, y = PC2)) +
  geom_abline(data = as.data.frame(slope), aes(slope=slope))

info <- ggplot_build(p)

x <- info$panel$ranges[[1]]$x.range[1]
y <- info$panel$ranges[[1]]$y.range[1]

p + 
  scale_x_continuous(breaks=y/slope, labels=names(slope)) +
  scale_y_continuous(breaks=x*slope, labels=names(slope)) +
  theme(axis.text.x  = element_text(angle=90, vjust=0.5),
        panel.grid.major = element_blank(),
        panel.grid.minor = element_blank(),
        axis.title.x=element_blank(),
        axis.title.y=element_blank()) 

Answer 2

Tal vez, como alternativa, podría eliminar el cuadro del panel y los ejes predeterminados, y dibujar un rectángulo más pequeño en la región de la trama. Recortar las líneas para que no coincidan con las etiquetas de texto es un poco complicado, pero esto podría funcionar.

df <- data.frame(x = -1:1, y = -1:1)
dfLabs <- data.frame(x = c(1, -1, 1/2), y = c(-0.75, -0.25, 1), 
                     labels = paste0("V", 1:3))
p <- ggplot(data = df, aes(x = x, y = y)) +  
  geom_blank() +
  geom_blank(data=dfLabs, aes(x = x, y = y)) +
  geom_text(data = dfLabs, mapping = aes(label = labels)) +
  geom_abline(intercept = rep(0, 3), slope = c(-0.75, 0.25, 2)) +
  theme_grey() +
  theme(axis.title = element_blank(), 
        axis.text = element_blank(), 
        axis.ticks = element_blank(),
        panel.grid = element_blank()) + 
  theme()

library(grid)
element_grob.element_custom <- function(element, ...)  {
  rectGrob(0.5,0.5, 0.8, 0.8, gp=gpar(fill="grey95"))
}

panel_custom <- function(...){ # dummy wrapper
  structure(
    list(...), 
    class = c("element_custom","element_blank", "element") 
  ) 

}

p <- p + theme(panel.background=panel_custom())


clip_layer <- function(g, layer="segment", width=1, height=1){
  id <- grep(layer, names(g$grobs[[4]][["children"]]))
  newvp <- viewport(width=unit(width, "npc"), 
                    height=unit(height, "npc"), clip=TRUE)
  g$grobs[[4]][["children"]][[id]][["vp"]] <- newvp

  g
}

g <- ggplotGrob(p)
g <- clip_layer(g, "segment", 0.85, 0.85)
grid.newpage()
grid.draw(g)