Introduccion

El objetivo de esta práctica es aplicar la técnica de componentes principales a las razones entre el área pulpar y el área total del diente en caninos, con fines de estimación de edad, es decir, esta se utilizara como una técnica exploratoria que permite reducir la dimension de los datos y resumir la variabilidad contenida en múltiples variables correlacionadas.

Defino mi directorio de trabajo

setwd("~/Blanca")

##Abriendo paquete pacman
library(pacman)
## Abriendo las librerias o paquetes que se usan
p_load(haven,dplyr,ggplot2,tinytex,tidyr,GGally,purrr,labelled,tidyverse,FactoMineR,factoextra)
Caninos <- read_sav("Base ejemplo estimacion edad.sav")

Calculando las razones Area pulpar /Area total

Caninos <- Caninos %>%
  mutate(
    RCSD = APSD / ACSD,   # Ratio canino superior derecho
    RCSI = APSI / ACSI,   # Ratio canino superior izquierdo
    RCID = APID / ACID,   # Ratio canino inferior derecho
    RCII = APII / ACII    # Ratio canino inferior izquierdo
  )

Variables de los Caninos

vars_ratios <- c("RCSD", "RCSI", "RCID","RCII")

Datos

datos2 <- Caninos %>% 
  select(all_of(vars_ratios), Sexo)

Convertir sexoN a factor (IMPORTANTE)

datos2$Sexo <- as_factor(datos2$Sexo)

PCA imputando NA

pca <- PCA(
  datos2 %>% select(all_of(vars_ratios)),
  scale.unit = TRUE,
  ncp = 5,
  graph = FALSE
)

El PCA se realizó a partir de las razones del área pulpar/área total del diente,por lo que se extrajeron cinco componentes principales, suficientes para describir la estructura de variación del conjunto de datos.

Gráfica scree-plot

fviz_screeplot(pca, addlabels = TRUE, ylim = c(0, 60))
## Warning in geom_bar(stat = "identity", fill = barfill, color = barcolor, :
## Ignoring empty aesthetic: `width`.

El grafico muestra que el primer componente principal concentra la mayor proporción de la varianza total, mientras que a partir del segundo componente va disminuyendo considerablemente.

Varianza explicada y por componente

varianza <- as.data.frame(pca$eig)
colnames(varianza) <- c("Eigenvalue", "Porcentaje", "Acumulado")
varianza
##        Eigenvalue Porcentaje Acumulado
## comp 1 3.71358662 92.8396655  92.83967
## comp 2 0.22773454  5.6933635  98.53303
## comp 3 0.03586229  0.8965574  99.42959
## comp 4 0.02281655  0.5704136 100.00000

El primer componente explica el 92.83 % de la varianza total, mientras que el segundo componente aporta solo un 5.69 %. En conjunto, estos dos componentes concentran el 98.53 % de la variabilidad total, lo que indica una fuerte correlación entre las variables analizadas y una estructura de datos alta.

Coeficientes de los componentes

loadings <- as.data.frame(pca$var$coord)
loadings
##          Dim.1      Dim.2       Dim.3       Dim.4
## RCSD 0.9658577 -0.2355475 -0.01740755 -0.10645799
## RCSI 0.9646826 -0.2406828  0.02125294  0.10491730
## RCID 0.9632636  0.2320607 -0.13419480  0.01621342
## RCII 0.9603210  0.2459097  0.13076444 -0.01458514

El primer componente presentan valores positivos y elevados para todas las variables, lo que indica que este componente esta asociado a las razones entre el area pulpar y el area total del diente.

Mientras que el segundo componente muestra lo opuesto entre los caninos superiores e inferiores, lo que sugiere la presencia de diferencias morfológicas secundarias relacionadas con la posición anatómica del diente.

Gráfica de los dos primeros componenetes

coords <- as.data.frame(pca$ind$coord[, 1:2])
colnames(coords) <- c("PC1", "PC2")

coords$Sexo <- datos2$Sexo   # añadir variable de agrupación

ggplot(coords, aes(x = PC1, y = PC2, color = Sexo)) +
  geom_point(size = 3, alpha = 0.8) +
  theme_minimal(base_size = 14) +
  labs(
    x = "Componente Principal 1",
    y = "Componente Principal 2",
    color = "Sexo"
  ) +
  theme(
    legend.position = "right",
    panel.grid.minor = element_blank(),
    panel.grid.major = element_line(color = "grey85")
  )

El grafico muestra que al incorporar la variable sexo como factor no se puede observar una separacion evidente entre hombre y mujeres, es decir que no se ve agrupamientos claros,esto podria sugierir que las razones de área pulpar/área total del diente no presentan un dimorfismo sexual marcado en esta muestra.

En conclusion esta practica nos permite resumir la variabilidad de las razones de área pulpar/área total del diente en caninos, lo que respalda la varianza del primer componente como un indicador del proceso de envejecimeinto dental, mientras que la ausencia de la separación por sexo sugiere que estas razones pueden ser aplicadas de forma general en estudios de estimación de edad.