Importacion De Librerias
library(gridExtra)
library(psych)
library(ggcorrplot)## Loading required package: ggplot2##
## Attaching package: 'ggplot2'## The following objects are masked from 'package:psych':
##
## %+%, alphalibrary(readxl)
library(dplyr)##
## Attaching package: 'dplyr'## The following object is masked from 'package:gridExtra':
##
## combine## The following objects are masked from 'package:stats':
##
## filter, lag## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, unionlibrary(tidyverse)## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ forcats 1.0.0 ✔ stringr 1.5.1
## ✔ lubridate 1.9.3 ✔ tibble 3.2.1
## ✔ purrr 1.0.2 ✔ tidyr 1.3.1
## ✔ readr 2.1.5## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ ggplot2::%+%() masks psych::%+%()
## ✖ ggplot2::alpha() masks psych::alpha()
## ✖ dplyr::combine() masks gridExtra::combine()
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errorslibrary(Amelia)## Loading required package: Rcpp
## ##
## ## Amelia II: Multiple Imputation
## ## (Version 1.8.2, built: 2024-04-10)
## ## Copyright (C) 2005-2024 James Honaker, Gary King and Matthew Blackwell
## ## Refer to http://gking.harvard.edu/amelia/ for more information
## ##library(janitor)##
## Attaching package: 'janitor'
##
## The following objects are masked from 'package:stats':
##
## chisq.test, fisher.testlibrary(magrittr)##
## Attaching package: 'magrittr'
##
## The following object is masked from 'package:purrr':
##
## set_names
##
## The following object is masked from 'package:tidyr':
##
## extractlibrary(ggplot2)
library(dplyr)
library(pastecs)##
## Attaching package: 'pastecs'
##
## The following object is masked from 'package:magrittr':
##
## extract
##
## The following object is masked from 'package:tidyr':
##
## extract
##
## The following objects are masked from 'package:dplyr':
##
## first, lastlibrary(nortest)
library(skimr)
library(haven)Importacion De Datos
# Instalar el paquete (si es necesario)
#install.packages("haven")
# Leer el archivo .sav
Data <- read_sav("deportistas (1).sav")Analisis Pre-eliminar De Datos
# Explorar los datos
head(Data)## # A tibble: 6 × 14
## RecGR RecGB Hematocrito Hemoglobina Ferritina IMC SumPliegues PrctGrasa
## <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 3.96 7.5 37.5 12.3 60 20.6 109. 19.8
## 2 4.41 8.3 38.2 12.7 68 20.7 103. 21.3
## 3 4.14 5 36.4 11.6 21 21.9 105. 19.9
## 4 4.11 5.3 37.3 12.6 69 21.9 126. 23.7
## 5 4.45 6.8 41.5 14 29 19.0 80.3 17.6
## 6 4.1 4.4 37.4 12.5 42 21.0 75.2 15.6
## # ℹ 6 more variables: MCMagra <dbl>, Altura <dbl>, Peso <dbl>,
## # Deporte <dbl+lbl>, Género <dbl+lbl>, `filter_$` <dbl+lbl>summary(Data)## RecGR RecGB Hematocrito Hemoglobina
## Min. :3.800 Min. : 3.300 Min. :35.90 Min. :11.60
## 1st Qu.:4.372 1st Qu.: 5.900 1st Qu.:40.60 1st Qu.:13.50
## Median :4.755 Median : 6.850 Median :43.50 Median :14.70
## Mean :4.719 Mean : 7.109 Mean :43.09 Mean :14.57
## 3rd Qu.:5.030 3rd Qu.: 8.275 3rd Qu.:45.58 3rd Qu.:15.57
## Max. :6.720 Max. :14.300 Max. :59.70 Max. :19.20
## Ferritina IMC SumPliegues PrctGrasa
## Min. : 8.00 Min. :16.75 Min. : 28.00 Min. : 5.630
## 1st Qu.: 41.25 1st Qu.:21.08 1st Qu.: 43.85 1st Qu.: 8.545
## Median : 65.50 Median :22.72 Median : 58.60 Median :11.650
## Mean : 76.88 Mean :22.96 Mean : 69.02 Mean :13.507
## 3rd Qu.: 97.00 3rd Qu.:24.46 3rd Qu.: 90.35 3rd Qu.:18.080
## Max. :234.00 Max. :34.42 Max. :200.80 Max. :35.520
## MCMagra Altura Peso Deporte
## Min. : 34.36 Min. :148.9 Min. : 37.80 Min. : 1.000
## 1st Qu.: 54.67 1st Qu.:174.0 1st Qu.: 66.53 1st Qu.: 2.000
## Median : 63.03 Median :179.7 Median : 74.40 Median : 4.000
## Mean : 64.87 Mean :180.1 Mean : 75.01 Mean : 4.525
## 3rd Qu.: 74.75 3rd Qu.:186.2 3rd Qu.: 84.12 3rd Qu.: 6.000
## Max. :106.00 Max. :209.4 Max. :123.20 Max. :10.000
## Género filter_$
## Min. :0.000 Min. :0.000
## 1st Qu.:0.000 1st Qu.:0.000
## Median :0.000 Median :0.000
## Mean :0.495 Mean :0.495
## 3rd Qu.:1.000 3rd Qu.:1.000
## Max. :1.000 Max. :1.000str(Data)## tibble [202 × 14] (S3: tbl_df/tbl/data.frame)
## $ RecGR : num [1:202] 3.96 4.41 4.14 4.11 4.45 4.1 4.31 4.42 4.3 4.51 ...
## ..- attr(*, "label")= chr "recuento glóbulos rojos en 10^12 / litro"
## ..- attr(*, "format.spss")= chr "F4.2"
## $ RecGB : num [1:202] 7.5 8.3 5 5.3 6.8 4.4 5.3 5.7 8.9 4.4 ...
## ..- attr(*, "label")= chr "recuento glóbulos blancos en 10^12 / litro"
## ..- attr(*, "format.spss")= chr "F4.1"
## $ Hematocrito: num [1:202] 37.5 38.2 36.4 37.3 41.5 37.4 39.6 39.9 41.1 41.6 ...
## ..- attr(*, "label")= chr "hematocrito (porcentaje)"
## ..- attr(*, "format.spss")= chr "F4.1"
## $ Hemoglobina: num [1:202] 12.3 12.7 11.6 12.6 14 12.5 12.8 13.2 13.5 12.7 ...
## ..- attr(*, "label")= chr "concentración hemoglobina en g por decalitro"
## ..- attr(*, "format.spss")= chr "F4.1"
## $ Ferritina : num [1:202] 60 68 21 69 29 42 73 44 41 44 ...
## ..- attr(*, "label")= chr "ferritina, ng por dl"
## ..- attr(*, "format.spss")= chr "F3.0"
## $ IMC : num [1:202] 20.6 20.7 21.9 21.9 19 ...
## ..- attr(*, "label")= chr "índice de masa corporal"
## ..- attr(*, "format.spss")= chr "F5.2"
## $ SumPliegues: num [1:202] 109.1 102.8 104.6 126.4 80.3 ...
## ..- attr(*, "label")= chr "suma de los pliegues de la piel"
## ..- attr(*, "format.spss")= chr "F5.1"
## $ PrctGrasa : num [1:202] 19.8 21.3 19.9 23.7 17.6 ...
## ..- attr(*, "label")= chr "porcentaje de grasa corporal"
## ..- attr(*, "format.spss")= chr "F5.2"
## $ MCMagra : num [1:202] 63.3 58.5 55.4 57.2 53.2 ...
## ..- attr(*, "label")= chr "masa corporal magra (lean body mass) Kg"
## ..- attr(*, "format.spss")= chr "F5.2"
## $ Altura : num [1:202] 196 190 178 185 185 ...
## ..- attr(*, "label")= chr "altura cm"
## ..- attr(*, "format.spss")= chr "F5.1"
## $ Peso : num [1:202] 78.9 74.4 69.1 74.9 64.6 63.7 75.2 62.3 66.5 62.9 ...
## ..- attr(*, "label")= chr "peso, Kg"
## ..- attr(*, "format.spss")= chr "F5.1"
## $ Deporte : dbl+lbl [1:202] 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, ...
## ..@ label : chr "deporte"
## ..@ format.spss : chr "F8.0"
## ..@ display_width: int 10
## ..@ labels : Named num [1:10] 1 2 3 4 5 6 7 8 9 10
## .. ..- attr(*, "names")= chr [1:10] "B_Ball" "Row" "Netball" "Swim" ...
## $ Género : dbl+lbl [1:202] 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, ...
## ..@ label : chr "género"
## ..@ format.spss : chr "F8.0"
## ..@ display_width: int 10
## ..@ labels : Named num [1:2] 0 1
## .. ..- attr(*, "names")= chr [1:2] "male" "female"
## $ filter_$ : dbl+lbl [1:202] 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, ...
## ..@ label : chr "Género=1 (FILTER)"
## ..@ format.spss : chr "F1.0"
## ..@ display_width: int 10
## ..@ labels : Named num [1:2] 0 1
## .. ..- attr(*, "names")= chr [1:2] "Not Selected" "Selected"missmap(Data, main="Mapa de Datos Faltantes en Datos crudos")## Warning: Unknown or uninitialised column: `arguments`.
## Unknown or uninitialised column: `arguments`.## Warning: Unknown or uninitialised column: `imputations`.
sapply(Data, class)## $RecGR
## [1] "numeric"
##
## $RecGB
## [1] "numeric"
##
## $Hematocrito
## [1] "numeric"
##
## $Hemoglobina
## [1] "numeric"
##
## $Ferritina
## [1] "numeric"
##
## $IMC
## [1] "numeric"
##
## $SumPliegues
## [1] "numeric"
##
## $PrctGrasa
## [1] "numeric"
##
## $MCMagra
## [1] "numeric"
##
## $Altura
## [1] "numeric"
##
## $Peso
## [1] "numeric"
##
## $Deporte
## [1] "haven_labelled" "vctrs_vctr" "double"
##
## $Género
## [1] "haven_labelled" "vctrs_vctr" "double"
##
## $`filter_$`
## [1] "haven_labelled" "vctrs_vctr" "double"# Resultado: a "integer" b "numeric" c "character"# Supongamos que 'datos' es tu dataframe con variables continuas en columnas 1 a 10
datos_long <- pivot_longer(Data, cols = 1:10, names_to = "variable", values_to = "valor")
# Lista de variables para iterar
variables <- unique(datos_long$variable)
# Crear y mostrar cada boxplot individualmente
for (var in variables) {
p <- ggplot(subset(datos_long, variable == var), aes(x = variable, y = valor)) +
geom_boxplot() +
labs(x = var, y = "Valor", title = paste("Boxplot de", var)) +
theme(axis.text.x = element_blank(), axis.ticks.x = element_blank())
print(p) # Mostrar el gráfico en el documento
}
# Crear histogramas para cada columna continua
for (i in 1:ncol(Data)) {
if (is.numeric(Data[, i])) { # Solo aplicar a columnas numéricas
p <- ggplot(Data, aes(x = Data[, i])) +
geom_histogram(binwidth = 1, fill = "blue", color = "black") +
labs(title = paste("Histograma de", colnames(Data)[i]), x = colnames(Data)[i], y = "Frecuencia")
print(p) # Mostrar el histograma
}
}Tratamiento De Datos
Data$Género <- as.factor(Data$Género)
#sapply(Data$Género, class)Procesamiento De Datos
# Función para identificar y reemplazar valores atípicos por NA
replace_outliers_with_na <- function(x) {
Q1 <- quantile(x, 0.25, na.rm = TRUE)
Q3 <- quantile(x, 0.75, na.rm = TRUE)
IQR <- Q3 - Q1
lower_bound <- Q1 - 1.5 * IQR
upper_bound <- Q3 + 1.5 * IQR
x[x < lower_bound | x > upper_bound] <- NA
return(x)
}
# Aplica la función a cada columna numérica del dataset
new_Data <- data.frame(lapply(Data, function(col) {
if (is.numeric(col)) {
return(replace_outliers_with_na(col))
} else {
return(col)
}
}))
# Ahora 'new_Data' contiene los mismos datos que 'Data' pero con valores atípicos reemplazados por NA.
missmap(new_Data, main="Mapa de Datos Faltantes en Datos Semiprocesados")
Pruebas de Normalidad
# Identificar columnas continuas (variables numéricas)
is_continuous <- function(x) {
return(is.numeric(x) && length(unique(x)) > 20) # Considera continua si tiene más de 20 valores únicos
}
# Aplicar el test de Shapiro-Wilk y agregar mensaje sobre la normalidad
shapiro_test_results <- lapply(Data, function(col) {
if (is_continuous(col)) {
test_result <- shapiro.test(col)
p_value <- test_result$p.value
normality_message <- ifelse(p_value > 0.05,
"La variable sigue una distribución normal.",
"La variable NO sigue una distribución normal.")
return(list(variable = colnames(Data)[which(sapply(Data, identical, y = col))],
p_value = p_value,
normality_message = normality_message))
} else {
return(NULL)
}
})
# Filtrar resultados para que solo incluyan las variables continuas
shapiro_test_results <- shapiro_test_results[!sapply(shapiro_test_results, is.null)]
# Mostrar resultados
for (result in shapiro_test_results) {
cat("Variable:", result$variable, "\n")
cat("P-valor:", result$p_value, "\n")
cat("Resultado del test:", result$normality_message, "\n\n")
}## Variable: RecGR
## P-valor: 0.0003452306
## Resultado del test: La variable NO sigue una distribución normal.
##
## Variable: RecGB
## P-valor: 2.590551e-05
## Resultado del test: La variable NO sigue una distribución normal.
##
## Variable: Hematocrito
## P-valor: 0.0002708842
## Resultado del test: La variable NO sigue una distribución normal.
##
## Variable: Hemoglobina
## P-valor: 0.01766546
## Resultado del test: La variable NO sigue una distribución normal.
##
## Variable: Ferritina
## P-valor: 5.265081e-11
## Resultado del test: La variable NO sigue una distribución normal.
##
## Variable: IMC
## P-valor: 2.342889e-06
## Resultado del test: La variable NO sigue una distribución normal.
##
## Variable: SumPliegues
## P-valor: 1.696909e-10
## Resultado del test: La variable NO sigue una distribución normal.
##
## Variable: PrctGrasa
## P-valor: 4.598649e-09
## Resultado del test: La variable NO sigue una distribución normal.
##
## Variable: MCMagra
## P-valor: 0.0128601
## Resultado del test: La variable NO sigue una distribución normal.
##
## Variable: Altura
## P-valor: 0.2121002
## Resultado del test: La variable sigue una distribución normal.
##
## Variable: Peso
## P-valor: 0.4515858
## Resultado del test: La variable sigue una distribución normal.# Función para identificar y reemplazar valores atípicos
replace_outliers_with_value <- function(x, value) {
Q1 <- quantile(x, 0.25, na.rm = TRUE)
Q3 <- quantile(x, 0.75, na.rm = TRUE)
IQR <- Q3 - Q1
lower_bound <- Q1 - 1.5 * IQR
upper_bound <- Q3 + 1.5 * IQR
x[x < lower_bound | x > upper_bound] <- value
return(x)
}
# Función para calcular la moda
get_mode <- function(x) {
ux <- unique(x)
ux[which.max(tabulate(match(x, ux)))]
}
# Realiza el test de Shapiro-Wilk y determina cómo reemplazar los valores atípicos
replace_outliers <- function(df) {
df_new <- df
for (col_name in names(df)) {
if (is.numeric(df[[col_name]])) {
# Test de Shapiro-Wilk
non_na_col <- df[[col_name]][!is.na(df[[col_name]])]
if (length(non_na_col) > 1) { # Asegurarse de que haya suficientes datos
test_result <- shapiro.test(non_na_col)
p_value <- test_result$p.value
# Reemplazar valores atípicos
if (p_value > 0.05) { # Normal
mean_value <- mean(non_na_col, na.rm = TRUE)
df_new[[col_name]] <- replace_outliers_with_value(df[[col_name]], mean_value)
} else { # No normal
median_value <- median(non_na_col, na.rm = TRUE)
df_new[[col_name]] <- replace_outliers_with_value(df[[col_name]], median_value)
}
}
} else if (is.factor(df[[col_name]]) || is.character(df[[col_name]])) {
# Reemplazar valores atípicos en variables categóricas por moda
mode_value <- get_mode(df[[col_name]])
df_new[[col_name]][is.na(df_new[[col_name]])] <- mode_value
}
}
return(df_new)
}
# Aplicar la función al conjunto de datos
new_Data <- replace_outliers(Data)
missmap(new_Data, main="Mapa de Datos Faltantes en Datos Limpios")## Warning: Unknown or uninitialised column: `arguments`.
## Unknown or uninitialised column: `arguments`.## Warning: Unknown or uninitialised column: `imputations`.
# Función para calcular la moda
get_mode <- function(x) {
ux <- unique(x)
ux[which.max(tabulate(match(x, ux)))]
}
# Realiza el test de Shapiro-Wilk y determina cómo reemplazar los valores atípicos
replace_outliers <- function(df) {
df_new <- df
for (col_name in names(df)) {
if (is.numeric(df[[col_name]])) {
# Test de Shapiro-Wilk
non_na_col <- df[[col_name]][!is.na(df[[col_name]])]
if (length(non_na_col) > 1) { # Asegurarse de que haya suficientes datos
test_result <- shapiro.test(non_na_col)
p_value <- test_result$p.value
# Reemplazar valores atípicos
if (p_value > 0.05) { # Normal
mean_value <- mean(non_na_col, na.rm = TRUE)
df_new[[col_name]] <- replace_outliers_with_value(df[[col_name]], mean_value)
} else { # No normal
median_value <- median(non_na_col, na.rm = TRUE)
df_new[[col_name]] <- replace_outliers_with_value(df[[col_name]], median_value)
}
}
} else if (is.factor(df[[col_name]]) || is.character(df[[col_name]])) {
# Reemplazar valores atípicos en variables categóricas por moda
mode_value <- get_mode(df[[col_name]])
df_new[[col_name]][is.na(df_new[[col_name]])] <- mode_value
}
}
return(df_new)
}
# Aplicar la función al conjunto de datos
new_Data <- replace_outliers(Data)Diferencia De La Proporcion De Hombres y Mujeres
# Crear una columna lógica para practicar deporte
Data$Practica_Deporte <- Data$Deporte >= 5
# Contar el número total de hombres y mujeres
n_1 <- sum(Data$Género == "1")
n_0 <- sum(Data$Género == "0")
# Contar cuántos hombres y mujeres practican deporte
n_1_deporte <- sum(Data$Género == "1" & Data$Deporte > 4)
n_0_deporte <- sum(Data$Género == "0" & Data$Deporte > 4)
print(n_1)## [1] 100# Calcular las proporciones
p1 <- n_1_deporte / n_1
p2 <- n_0_deporte / n_0
# Calcular el error estándar
SE <- sqrt((p1 * (1 - p1) / n_1) + (p2 * (1 - p2) / n_0))
# Valor crítico Z para un intervalo de confianza del 92%
Z <- qnorm(1 - (1 - 0.92) / 2)
# Calcular el intervalo de confianza
diferencia <- p1 - p2
IC_inf <- diferencia - Z * SE
IC_sup <- diferencia + Z * SE
# Mostrar el intervalo de confianza
cat("Intervalo de confianza al 92% para la diferencia entre proporciones:\n")## Intervalo de confianza al 92% para la diferencia entre proporciones:cat("(", IC_inf, ", ", IC_sup, ")\n")## ( -0.3959069 , -0.1597794 )En una prueba de dos colas, el intervalo de confianza del 92% que has proporcionado indica que la diferencia entre las proporciones es significativamente diferente de cero. Por lo tanto, se rechazaría la hipótesis nula al nivel de significancia del 8% (o al 92% de confianza).