Entrega_Final_Estadistica
Jhonathan Correa - Camilo Rojas
2024-04-20
Se carga la tabla para desarrollar el ejercicio.
library(ggplot2)
#Se muestran los datos
head (diamonds)## # A tibble: 6 × 10
## carat cut color clarity depth table price x y z
## <dbl> <ord> <ord> <ord> <dbl> <dbl> <int> <dbl> <dbl> <dbl>
## 1 0.23 Ideal E SI2 61.5 55 326 3.95 3.98 2.43
## 2 0.21 Premium E SI1 59.8 61 326 3.89 3.84 2.31
## 3 0.23 Good E VS1 56.9 65 327 4.05 4.07 2.31
## 4 0.29 Premium I VS2 62.4 58 334 4.2 4.23 2.63
## 5 0.31 Good J SI2 63.3 58 335 4.34 4.35 2.75
## 6 0.24 Very Good J VVS2 62.8 57 336 3.94 3.96 2.48#La base de datos Diamonds se muestran 53940 registros y 10 variables
dim(diamonds)## [1] 53940 10Para realizar el analisis exploratorio multivariado vamos a realizar los siguientes pasos:
1. Estadística tradicional
A partir de la base de datos denominda diamonts, se realizará un análisis exploratorio multivariado que nos permitiran describir el comportamiento de las variables con respecto a la variable precio.
a. Analisis Exploratorio por variable cuantitativa omitiendo las variables x y z
library(dplyr)
# Resumen estadístico de las variables
summary(diamonds)## carat cut color clarity depth
## Min. :0.2000 Fair : 1610 D: 6775 SI1 :13065 Min. :43.00
## 1st Qu.:0.4000 Good : 4906 E: 9797 VS2 :12258 1st Qu.:61.00
## Median :0.7000 Very Good:12082 F: 9542 SI2 : 9194 Median :61.80
## Mean :0.7979 Premium :13791 G:11292 VS1 : 8171 Mean :61.75
## 3rd Qu.:1.0400 Ideal :21551 H: 8304 VVS2 : 5066 3rd Qu.:62.50
## Max. :5.0100 I: 5422 VVS1 : 3655 Max. :79.00
## J: 2808 (Other): 2531
## table price x y
## Min. :43.00 Min. : 326 Min. : 0.000 Min. : 0.000
## 1st Qu.:56.00 1st Qu.: 950 1st Qu.: 4.710 1st Qu.: 4.720
## Median :57.00 Median : 2401 Median : 5.700 Median : 5.710
## Mean :57.46 Mean : 3933 Mean : 5.731 Mean : 5.735
## 3rd Qu.:59.00 3rd Qu.: 5324 3rd Qu.: 6.540 3rd Qu.: 6.540
## Max. :95.00 Max. :18823 Max. :10.740 Max. :58.900
##
## z
## Min. : 0.000
## 1st Qu.: 2.910
## Median : 3.530
## Mean : 3.539
## 3rd Qu.: 4.040
## Max. :31.800
## # Mostramos los nombres de variables
names(diamonds)## [1] "carat" "cut" "color" "clarity" "depth" "table" "price"
## [8] "x" "y" "z"# Histogramas de cada variable omitiendo las variables x y z
hist(diamonds$carat, main = "Histograma de QUILATES", xlab = "QUILATES")
hist(diamonds$depth, main = "Histograma de PROFUNDIDAD", xlab = "PROFUNDIDAD")
hist(diamonds$table, main = "Histograma de TABLA", xlab = "TABLA")
hist(diamonds$price, main = "Histograma de PRECIO", xlab = "PRECIO")
# Diagramas de caja
#par(mfrow=c(2,1))
boxplot(diamonds$carat, main = "Boxplot de QUILATES")
boxplot(diamonds$cut, main = "Boxplot de CORTE")
boxplot(diamonds$color, main = "Boxplot de COLOR")
boxplot(diamonds$clarity, main = "Boxplot de CLARIDAD")
boxplot(diamonds$depth, main = "Boxplot de PROFUNDIDAD")
boxplot(diamonds$table, main = "Boxplot de TABLA")
boxplot(diamonds$price, main = "Boxplot de PRECIO")
# Diagrama de dispersión
pairs(diamonds)
b. Analisis Exploratorio por variable cualitativa
# Tabla "cut"
tabla_corte = table(diamonds$cut)
tabla_corte##
## Fair Good Very Good Premium Ideal
## 1610 4906 12082 13791 21551# Gráfico de barras"cut"
barplot(tabla_corte, main = "Frecuencia de cortes de diamante", xlab = "Cut", ylab = "Frecuencia")
# Gráfico de barras "cut" (ggplot2)
ggplot(data = diamonds, aes(x = cut)) +
geom_bar(fill = "skyblue", color = "black") +
labs(title = "Frecuencia de cortes de diamante", x = "Cut", y = "Frecuencia") + geom_text(stat='count', aes(label=..count..), vjust=-0.5)
# Tabla "color"
tabla_color = table(diamonds$color)
tabla_color##
## D E F G H I J
## 6775 9797 9542 11292 8304 5422 2808# Gráfico de barras "color"
barplot(tabla_color, main = "Frecuencia de colores de diamante", xlab = "Color", ylab = "Frecuencia")
# Gráfico de barras "color" (ggplot2)
ggplot(data = diamonds, aes(x = color)) +
geom_bar(fill = "lightgreen", color = "black") +
labs(title = "Frecuencia de colores de diamante", x = "Color", y = "Frecuencia") + geom_text(stat='count', aes(label=..count..), vjust=-0.5)
# Tabla "clarity"
tabla_claridad = table(diamonds$clarity)
# tabla_claridad
# Gráfico de barras "clarity"
barplot(tabla_claridad, main = "Frecuencia de claridades de diamante", xlab = "Clarity", ylab = "Frecuencia")
# Gráfico de barras "clarity" (ggplot2)
ggplot(data = diamonds, aes(x = clarity)) +
geom_bar(fill = "salmon", color = "black") +
labs(title = "Frecuencia de claridades de diamante", x = "Clarity", y = "Frecuencia") + geom_text(stat='count', aes(label=..count..), vjust=-0.5)
c. Analisis Inferencial por variable
library(Rcmdr)
library(abind, pos=20)
library(e1071, pos=21)
numSummary(diamonds[,c("carat", "depth", "table", "price"), drop=FALSE], statistics=c("mean", "se(mean)", "var",
"quantiles", "CV"), quantiles=c(0,.25,.5,.75,1))## mean se(mean) var CV 0% 25% 50%
## carat 0.7979397 0.002040954 2.246867e-01 0.59404391 0.2 0.4 0.7
## depth 61.7494049 0.006168448 2.052404e+00 0.02320057 43.0 61.0 61.8
## table 57.4571839 0.009621063 4.992948e+00 0.03888966 43.0 56.0 57.0
## price 3932.7997219 17.177360816 1.591563e+07 1.01440196 326.0 950.0 2401.0
## 75% 100% n
## carat 1.04 5.01 53940
## depth 62.50 79.00 53940
## table 59.00 95.00 53940
## price 5324.25 18823.00 53940scatterplotMatrix(~carat+depth+table+price,
regLine=FALSE, smooth=FALSE, diagonal=list(method="density"), data=diamonds)
Con la anterior información se puede analizar lo siguiente:
En la base de datos se pueden encontrar mayormente diamantes de 1,5 kilates o menos.
El precio de los diamantes según el histograma decrece casi de una manera exponencial considerando que hay menos diamantes más costosos y mayor cantidad de diamantes con una con un precio menor.
Existen 21.551 diamantes que pertenecen a la categoría Ideal la cual es la clase dominante en los cortes.
La clasificación de color G es la más dominante con 11.292 diamantes; esta clasificacion G se refiere a los diamantes que tienen una ligera coloración, pero aún son considerados de alta calidad y son ampliamente utilizados en joyería fina.
La menor es la categoría J con 2.808 diamantes; esta clasificacion J se refiere a Los diamantes de esta categoría tienen una coloración más pronunciada que los diamantes de las categorías anteriores y pueden mostrar un color amarillento o marrón claro.
La mayor cantidad de claridad de diamantes está situado en la categoría SI1 con 13.065 diamantes; esta clasificacion SI1 (Slightly Included 1) los diamantes tienen inclusiones que son visibles bajo una lupa de 10 aumentos, pero son relativamente pequeñas y no son fácilmente visibles a simple vista sin la ayuda de una lupa.
la categoría con menos cantidad de diamantes es la I1 con 741, esta clasificacion I1 (Included 1) los diamantes tienen inclusiones obvias que son fácilmente visibles con lupa de 10 aumentos, y estas inclusiones pueden afectar significativamente la apariencia y la transparencia del diamante.
d . Correlación
##Para hacer la correlacion se requieren solo las variables cuantitativas para lo cual segmentaremos la bd solo con datos cuantitativos llamada **diamonds_c**
diamonds_c = diamonds[,c("carat", "depth", "table", "price", "x", "y", "z")]
diamonds_c## # A tibble: 53,940 × 7
## carat depth table price x y z
## <dbl> <dbl> <dbl> <int> <dbl> <dbl> <dbl>
## 1 0.23 61.5 55 326 3.95 3.98 2.43
## 2 0.21 59.8 61 326 3.89 3.84 2.31
## 3 0.23 56.9 65 327 4.05 4.07 2.31
## 4 0.29 62.4 58 334 4.2 4.23 2.63
## 5 0.31 63.3 58 335 4.34 4.35 2.75
## 6 0.24 62.8 57 336 3.94 3.96 2.48
## 7 0.24 62.3 57 336 3.95 3.98 2.47
## 8 0.26 61.9 55 337 4.07 4.11 2.53
## 9 0.22 65.1 61 337 3.87 3.78 2.49
## 10 0.23 59.4 61 338 4 4.05 2.39
## # ℹ 53,930 more rows## Matriz de correlacion 1
library(corrplot)
matr_corr = cor(diamonds_c)
matr_corr## carat depth table price x y
## carat 1.00000000 0.02822431 0.1816175 0.9215913 0.97509423 0.95172220
## depth 0.02822431 1.00000000 -0.2957785 -0.0106474 -0.02528925 -0.02934067
## table 0.18161755 -0.29577852 1.0000000 0.1271339 0.19534428 0.18376015
## price 0.92159130 -0.01064740 0.1271339 1.0000000 0.88443516 0.86542090
## x 0.97509423 -0.02528925 0.1953443 0.8844352 1.00000000 0.97470148
## y 0.95172220 -0.02934067 0.1837601 0.8654209 0.97470148 1.00000000
## z 0.95338738 0.09492388 0.1509287 0.8612494 0.97077180 0.95200572
## z
## carat 0.95338738
## depth 0.09492388
## table 0.15092869
## price 0.86124944
## x 0.97077180
## y 0.95200572
## z 1.00000000png("corrplot1.png", width = 800, height = 800)
corrplot(matr_corr, method = "color",addCoef.col = "black")
dev.off()## png
## 2knitr::include_graphics("corrplot1.png")
Segun los datos de correlacion y el el mapa de calor podemos verificar que:
Correlacion positiva:
Precio - Kilates = 0.92
Precio - Tabla = 0.13
Precio - X = 0.88
Precio - Y = 0.87
Precio - Z = 0.86
Correlacion negativa
Precio - Profundidad = -0.01
2. Método Supervisado
A partir de la base de datos denominda diamonts, se realizará el análisis con un metodo supervisado para validar el comportamiento de las variables independientes con respecto a la variable precio que sera nuestra variable dependiente para explicar su razon de ser y el paso de cada variable para determinar el precio
Analisis con Regresión Logistica
paso1: Representar en binario
Como la Regresión lineal trabaja en base a la deficion de dos estados (binario), es decir si algo ocurre o no ocurre, para lo cual, si deseamo realizar la regresion logistica sobre una variable cuantitativa como lo es Precio entonces debemos transformarla en binomio.
Generalmente en analítica de datos cuando tenemos valores como variable dependiente lo que se hace es que se puede clasificar si el valor (en este caso el precio) es alto o bajo, para lo cual podemos partir de la mediana (estadisticamente el punto medio de una data) y determinar que todo lo que este por encima de la mediana es Precio ALTO y todo lo que sea igual o menor que eso es BAJO
#Se crea el binario, donde 1 es ALTO y 0 es BAJO
diamonds_c$binario_price = ifelse(diamonds_c$price > median(diamonds_c$price), 1, 0)
#Se identifican cuando hay Altos y Bajos
table(diamonds_c$binario_price)##
## 0 1
## 26985 26955paso2: Preparacion de la data de 70% entrenamiento y 30% prueba
set.seed(123)
indice_e = sample(1:nrow(diamonds_c), 0.7 * nrow(diamonds_c))
d_entrenamiento = diamonds_c[indice_e, ]
d_prueba = diamonds_c[-indice_e, ]paso3: Desarrollar el modelo
#Se ajusta el modelo logístico
m_log = glm(binario_price ~ ., data = d_entrenamiento, family = "binomial")
#Se muestra el modelo
summary(m_log)##
## Call:
## glm(formula = binario_price ~ ., family = "binomial", data = d_entrenamiento)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -8.49 0.00 0.00 0.00 8.49
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.366e+16 2.842e+07 -8.325e+08 <2e-16 ***
## carat -7.577e+15 4.203e+06 -1.803e+09 <2e-16 ***
## depth 9.114e+13 3.819e+05 2.386e+08 <2e-16 ***
## table 6.967e+12 1.665e+05 4.185e+07 <2e-16 ***
## price 6.412e+11 2.341e+02 2.739e+09 <2e-16 ***
## x 2.871e+15 3.114e+06 9.219e+08 <2e-16 ***
## y 3.593e+14 1.202e+06 2.990e+08 <2e-16 ***
## z 8.361e+14 4.690e+06 1.783e+08 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 52344 on 37757 degrees of freedom
## Residual deviance: 65311 on 37750 degrees of freedom
## AIC: 65327
##
## Number of Fisher Scoring iterations: 25paso4: Verificacion de la bondad del modelo con datos
A continuación se validará que tan acertado es el modelo para clasificar los datos
library(vcd)## Warning: package 'vcd' was built under R version 4.2.3## Loading required package: gridprediccion = ifelse(test = m_log$fitted.values > 0.5, yes = 1, no = 0)
mc = table(m_log$model$binario_price, prediccion, dnn = c("observaciones", "predicciones"))
mc## predicciones
## observaciones 0 1
## 0 18590 325
## 1 581 18262mosaic(mc,shade = T, colorize = T, gp = gpar(fill = matrix(c("#447270","#f6b915", "#f6b915", "#447270"), 2, 2)))
paso5: Verificacion de la cuenta de
\[R^2\] del modelo con datos
A continuación se validará la cuenta del r2 el modelo para clasificar los datos
cuenta_r2 = sum(diag(mc))/sum(mc)
cuenta_r2## [1] 0.9760051Se puede validar que estuvo bien contado casi en un 100%
paso6: Desarrollar la predicción del modelo
#Se realiza el paso fundamental de probar con los datos de prueba una prediccion
pred_m_logistica = predict(m_log, newdata = d_prueba, type = "response")
summary(pred_m_logistica)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.0000 0.0000 0.0000 0.4972 1.0000 1.0000paso7: Evaluacion del modelo
# Evaluación del modelo de regresión logística
prediccion_binaria = ifelse(pred_m_logistica > 0.5, "1", "0")
matriz_confusion = table(d_prueba$binario_price, prediccion_binaria)
print("Matriz de confusion del modelo logistico:")## [1] "Matriz de confusion del modelo logistico:"matriz_confusion## prediccion_binaria
## 0 1
## 0 7917 153
## 1 220 7892precision = sum(diag(matriz_confusion)) / sum(matriz_confusion)
paste("Precision del modelo logistico:", precision)## [1] "Precision del modelo logistico: 0.976949697194413"3. Método No Supervisado
A partir de la base de datos denominda diamonts, se realizará el análisis con un metodos no supervisados para validar el comportamiento de las variables con respecto a la variable precio.
Analisis con clustering K-Means
El clustering es un tipo de aprendizaje no supervisado que agrupa los datos en grupos basados en su similitud.
#Se utilizara la data que ya teniamos del ejercicio anterio con datos cuantitativos
diamonds_c## # A tibble: 53,940 × 8
## carat depth table price x y z binario_price
## <dbl> <dbl> <dbl> <int> <dbl> <dbl> <dbl> <dbl>
## 1 0.23 61.5 55 326 3.95 3.98 2.43 0
## 2 0.21 59.8 61 326 3.89 3.84 2.31 0
## 3 0.23 56.9 65 327 4.05 4.07 2.31 0
## 4 0.29 62.4 58 334 4.2 4.23 2.63 0
## 5 0.31 63.3 58 335 4.34 4.35 2.75 0
## 6 0.24 62.8 57 336 3.94 3.96 2.48 0
## 7 0.24 62.3 57 336 3.95 3.98 2.47 0
## 8 0.26 61.9 55 337 4.07 4.11 2.53 0
## 9 0.22 65.1 61 337 3.87 3.78 2.49 0
## 10 0.23 59.4 61 338 4 4.05 2.39 0
## # ℹ 53,930 more rows#Se requiere normalizar los datos para agruparlos
diamonds_escala = scale(diamonds_c)
#Se aplica K-Means para agruparlo a 4 grupos
set.seed(123)
k = 4
modelo_kmeans = kmeans(diamonds_escala, centers = k)
diamonds_cluster = data.frame(diamonds, cluster = as.factor(modelo_kmeans$cluster))
# Se presentan los resultados con centroides de cada grupo
modelo_kmeans$centers## carat depth table price x y
## 1 0.3863477 0.07611977 0.09784957 0.2355023 0.5421642 0.5288220
## 2 1.9437537 -0.01976453 0.28057611 2.0726390 1.7097203 1.6761105
## 3 -0.8001847 0.26527592 -0.58024970 -0.7084794 -0.8750148 -0.8536355
## 4 -0.7056210 -0.90725491 1.04772188 -0.6704049 -0.7005902 -0.6909408
## z binario_price
## 1 0.5397575 0.9914332
## 2 1.6717835 0.9999704
## 3 -0.8287951 -0.9906003
## 4 -0.7838106 -0.9252300#Por ultimo se presente el gráfico de dispersión del precio vs. quilates
ggplot(diamonds_cluster, aes(x = carat, y = price, color = cluster)) +
geom_point() +
labs(title = "Precio vs. Quilates con Clustering", x = "Quilates", y = "Precio") +
scale_color_discrete(name = "Cluster")