Challenge #1
En esta actividad se analizarán datos provenientes de una tarea repetitiva en niños y adultos diagnosticados y no diagnosticados en Trastorno de Déficit de Atención con Hiperactividad (ADHD en inglés), residentes en Barranquilla.
Los datos se encuentran aquí.
Las variables de interés son sexo, edad, adhdstatus y las variables del seguimiento trait_A1, trait_A2, \(...\), trait_A50. Estas últimas representan el estado de finalización de la tarea. La tarea se cuantifica en una escala de 1 a 5. Por simplicidad, valores diferentes a 5 se consideran no exitosos.
Fecha de entrega: Sábado, 25 de Mayo de 2024.
Suponga que la respuesta de un individuo puede resumirse en el vector 01000111111101100100001110100111100110000111001110. Construya una función que permita calcular la entropía de Shannon a partir de un string de 0s y 1s. Calcule la entropía \(H\) para cada individuo. Estudie la distribución de \(H_1, H_2,\ldots, H_n\) por sexo y dignóstico de ADHD. Qué observa?
# Función para calcular la entropía de Shannon
shannon_entropia <- function(v) {
counts <- table(v)
probs <- prop.table(counts)
entropia <- -sum(probs * log2(probs))# Calcular la entropía de Shannon
return(entropia)
}
# Vector de respuesta del individuo
v <- "01000111111101100100001110100111100110000111001110"
# Calcular la entropía de Shannon para el vector de respuesta
entropia_v <- round(shannon_entropia(strsplit(v, "")[[1]]),4)Respuesta. El valor de la Entropía de Shannon para el vector del individuo del P1 es de 0.9954, lo que sugiere un alto grado de variabilidad en los datos.
Para profundizar en este análisis, procederemos a examinar la entropía para cada uno de los individuos, considerando tanto el sexo como el diagnóstico de ADHD.
Siguiendo la instrucción establecida en la introducción, procedemos a transformar los datos para calcular la entropía de cada individuo en nuestro conjunto de datos. La escala de calificiación de cada tarea va del 1 al 5. Para simplificar, valores distintos de 5 se consideran no exitosos, es decir, 0, mientras que los valores iguales a 5 se consideran exitosos, es decir, 1.
datos_t <- ifelse(datos[,5:53] < 5, 0, 1) #transformación de datos, donde cualquier puntaje diferente de 5 se considera no exitoso, es decir toma le valor de 0.
datos_p1 <- cbind(datos$uid, datos$sexo, datos$edad, datos$adhdstatus,ifelse(datos[,5:53] < 5, 0, 1))
colnames(datos_p1)[1:4] <- c('uid','sexo', 'edad', 'adhdstatus') # Renombrar las columnas en el dataframe temporalA continuación se describe función para el cálculo de la entrpía para cada individuo,
df_respuestas <- data.frame(respuesta = apply(datos_p1[, -c(2:5)], 1, function(row) {
paste(row[-1], collapse = "")
}), uid = datos_p1[,1])
entropia_dfres <- sapply(strsplit(df_respuestas$respuesta, ""), function(respuesta) {
round(shannon_entropia(respuesta), 4)
})
df_entropia_total <- data.frame(entropia_dfres)
df_entropia_total<- cbind(datos$uid, datos$sexo, datos$edad, datos$adhdstatus, df_entropia_total$entropia_dfres)
colnames(df_entropia_total)[1:5] <- c('uid','sexo', 'edad', 'adhdstatus', 'entropia') # Renombrar las columnas en el dataframe A continuación, se presenta el valor de entropía correspondiente a cada individuo
df_entropia_total <- data.frame(df_entropia_total)
df_entropia_total%>%
group_by(sexo) %>%
plot_ly() %>%
add_trace(data = df_entropia_total,
x = ~sexo,
y = ~entropia,
text =~entropia,
type = 'violin',
box = list(visible = T),
meanline = list(visible = T),
color = ~sexo,
colors = c("#8C4D3F","#1B7F7A"))%>% # cafe y azul
layout(title = "Distribución de la Entropía por Género",
xaxis = list(title = "Género"),
yaxis = list(title = "Valor de Entropía"))df_entropia_total <- data.frame(df_entropia_total)
df_entropia_total%>%
group_by(sexo) %>%
plot_ly() %>%
add_trace(data = df_entropia_total,
x = ~entropia,
y = ~sexo,
type = 'histogram',
color = ~sexo,
colors = c("#8C4D3F","#1B7F7A"))%>% # cafe y azul
layout(title = "Distribución de la Entropía por Género",
xaxis = list(title = "Género"),
yaxis = list(title = "Valor de Entropía"))Para facilitar el análisis del gráfico, es importante tener en cuenta las siguientes designaciones:
Basándonos en los gráficos anteriores, se puede afirmar que la distribución de la entropía en función del género es asimétrica con una cola a la derecha y un sesgo a la izquierda. Esta asimetría indica que la mayor concentración de datos se encuentra en los valores más altos de entropía, mientras que el sesgo hacia la izquierda sugiere la presencia de valores atípicos que están bastante distantes de la mayoría de las observaciones. Estos valores atípicos requieren un análisis más detenido para comprender su influencia en los datos y su posible impacto en la interpretación de los resultados.
df_entropia_total$adhdstatus <- factor(df_entropia_total$adhdstatus)
df_entropia_total$sexo <- factor(df_entropia_total$sexo)
fig_v_p1 <- df_entropia_total %>%
plot_ly(
x = ~sexo,
y = ~entropia,
type = 'violin',
color = ~adhdstatus,
colors = c("#8C4D3F","#1B7F7A"),
box = list(visible = TRUE),
meanline = list(visible = TRUE)
) %>%
layout(
violinmode = "group",
yaxis = list(zeroline = FALSE, title = "Valor de Entropia"),
title = "Distribución de la Entropía por Género y Diagnóstico",
xaxis = list(title = "Género")
)
fig_v_p1Para facilitar el análisis del gráfico, es importante tener en cuenta las siguientes designaciones:
Género: F = Female, M = Male
Diagnóstico: 0 = Enfermo, 1 = Sano
Basándonos en el gráfico anterior, se confirma que la distribución de la entropía según el género y el diagnóstico (enfermo o sano) muestra asimetría, con una cola hacia la derecha y un sesgo hacia la izquierda en el caso de los individuos masculinos. Esta asimetría indica que la concentración principal de datos se encuentra en los valores más altos de entropía, mientras que el sesgo hacia la izquierda sugiere la presencia de valores atípicos, los cuales están significativamente alejados de la mayoría de las observaciones. Estos valores atípicos necesitan ser analizados detenidamente para entender su influencia en los datos y su posible repercusión en la interpretación de los resultados.
Asimismo, se observa que en el caso de las mujeres, ya sean diagnosticadas como sanas o enfermas, los valores de entropía exhiben una coincidencia entre la mediana y la media. Esto sugiere simetría en la distribución. Sin embargo, es importante destacar que los datos no siguen una distribución normal, como se evidenció en el análisis previo.
Conside el vector anterior. Construya una función que calcule el número de cambios de estado. En este caso, una matriz de transición podría ayudar.
# Vector de respuesta del individuo P1
V <- "01000111111101100100001110100111100110000111001110"
#Función Magina
magia <- function(V) {
#número de caracteres
n <- nchar(V)
aux = as.numeric(strsplit(V,"")[[1]])
#número de 1s
n1 = sum(aux == 1)
#número de 0s
n0 = sum(aux == 0)
# aux lag
auxlag1 <- c(aux[-1], NA)
nij <- table(aux,auxlag1)
names(nij) <- c('n00','n10','n01','n11')
# Crear matriz
matriz <- matrix(c(nij['n00'], nij['n10'], nij['n01'], nij['n11']), nrow = 2, byrow = TRUE)
rownames(matriz) <- c('0', '1')
colnames(matriz) <- c('0', '1')
# Resultado
list(n = n, n1 = n1, n0 = n0, switch = sum(nij[2:3]), nij = matriz)
}Respuesta. El número de cambios de estado al completar una tarea repetitiva por parte de un individuo, suponiendo que sus respuestas se resumen en el vector 01000111111101100100001110100111100110000111001110, es de 20.
Construya la matriz de transición para el individuo 83. Calcule \[P(s+1 = j | s = i)\] donde \(s\) es el intento e \(i,j=\{0,1\}\). Defina esta matriz de probabilidades como \(\mathbf{P}^{(1)}\). Tenga en cuenta que \(\mathbf{P}^{(1)}\) es de dimensión \(2\times 2\).
Respuesta. Se requiere construir la matriz de transición para el individuo número 83, relacionada a continuacion:
\[\begin{bmatrix} 14 & 14\\ 13 & 6 \end{bmatrix}\]
Para el calcular la matriz de probabilidades \(P^{(1)}\), necesitamos calcular las probabilidades de transición de \(i\) a \(j\) para cada par de estados \(i\), \(j\) en el primer paso. Por ejemplo, \(P(s+1=0∣s=0)\) representa la probabilidad de que el estado en el siguiente intento sea 0 dado que el estado actual es 0.
A continuación se visualiza la matriz de probabilidades \(P^{(1)}\):
\[ P^{(1)} = \begin{bmatrix} 0.5186 & 0.4814\\ 0.7000 & 0.3000 \end{bmatrix}\]
De lo anterior se puede afirmar que para el individuo 83 al completar una tarea repetitiva:
i_83 <- df_respuestas[df_respuestas$uid == 83, "respuesta"]
t_matriz <- magia(i_83)# Función Matriz de probabilidad
p_matriz <- function(V) {
# Número de caracteres
n <- nchar(V)
aux <- as.numeric(strsplit(V,"")[[1]])
# Auxiliar para el lag
auxlag1 <- c(aux[-1], NA)
nij <- table(aux, auxlag1)
names(nij) <- c('n00','n10','n01','n11')
# Crear matriz de probabilidades
P1 <- matrix(0, nrow = 2, ncol = 2)
# Calcular probabilidades (dada la condición del enunciado la probabilidad se calcula de esta forma)
P1[1, 1] <- nij['n00'] / sum(nij[c('n00', 'n01')])
P1[1, 2] <- nij['n01'] / sum(nij[c('n00', 'n01')])
P1[2, 1] <- nij['n10'] / sum(nij[c('n10', 'n11')])
P1[2, 2] <- nij['n11'] / sum(nij[c('n10', 'n11')])
# Resultado
return(P1)
}matriz_i_83 <- p_matriz(i_83)Construya la matriz de transición en el paso \(k\) utilizando la propiedad de Markov para matrices de transición, esto es \[ \mathbf{P}^{(k)}_M = \underset{k\text{-veces}}{\underbrace{\mathbf{P}^{(1)}\times \mathbf{P}^{(1)}\times\mathbf{P}^{(1)}\times\cdots\times\mathbf{P}^{(1)}}} \]
En la expresión anterior, \(M\) simboliza el hecho de que está utilizando la propiedad de Markov para matrices de transición. Además, el símbolo \(\times\) se refiere a multiplicación matricial y no a potencias.
Respuesta. La propiedad de Markov para matrices de transición establece que la matriz de transición en el paso \(k\) puede obtenerse multiplicando la matriz de transición en el primer paso \(P^{(1)}\) consigo misma \(k−1\) veces. Para mas detalle ver aquí.
A continuación se visualiza la matriz de probabilidades \(P^{(47)}_M\)
\[ P^{(47)}_M = \begin{bmatrix} 0.5925 & 0.4075\\ 0.5925 & 0.4075 \end{bmatrix}\]
De lo anterior se puede afirmar que para el individuo 83 al completar una tarea repetitiva:
k <- nchar(df_respuestas[1, "respuesta"])
k[1] 48# Función para construir la matriz de transición en el paso k
p_k_matriz <- function(P1, k) {
# Inicializar la matriz de transición en el paso k
P_k <- P1
# Realizar la multiplicación matricial de P1 k-1 veces
for (i in 1:(k - 1)) {
P_k <- P_k %*% P1
}
return(P_k)
}p_k_matriz_i_83 <- p_k_matriz(matriz_i_83,k)Calcule \(\mathbf{P}^{(k)}\) como \(P(s+k = j | s = i)\) para \(k=\{1,2,3,4\}\). Use una prueba \(\chi^2\) para tablas de contingencia y compare estos resultados con \(\mathbf{P}^{(k)}_M\). Concluya.
Respuesta. Aquí escribe la respuesta.
A continuación se describe código con función para creación de tablas de contingencia.
# Función para generar la tabla de contingencia
c_tabla <- function(P) {
n <- nrow(P)
table_values <- c(P[1, 1], P[1, 2], P[2, 1], P[2, 2])
c_tabla <- matrix(table_values, nrow = 2, byrow = TRUE)
rownames(c_tabla) <- c("s = 0", "s = 1")
colnames(c_tabla) <- c("s+k = 0", "s+k = 1")
return(c_tabla)
}Se calcula la matriz de probabilidad para el individuo \(83\) para \(k=\{1,2,3,4\}\) y se generan tablas de contingencia.
p_k_m_1 <- p_k_matriz(matriz_i_83,1)
p_k_m_2 <-p_k_matriz(matriz_i_83,2)
p_k_m_3 <-p_k_matriz(matriz_i_83,3)
p_k_m_4 <-p_k_matriz(matriz_i_83,4)
c_tabla1 <- c_tabla(p_k_m_1)
c_tabla2 <- c_tabla(p_k_m_2)
c_tabla3 <- c_tabla(p_k_m_3)
c_tabla4 <-c_tabla(p_k_m_4)c_tabla1 s+k = 0 s+k = 1
s = 0 0.5900406 0.4099594
s = 1 0.5960178 0.4039822c_tabla2 s+k = 0 s+k = 1
s = 0 0.6058985 0.3941015
s = 1 0.5729630 0.4270370c_tabla3 s+k = 0 s+k = 1
s = 0 0.5900406 0.4099594
s = 1 0.5960178 0.4039822c_tabla4 s+k = 0 s+k = 1
s = 0 0.5929185 0.4070815
s = 1 0.5918338 0.4081662Se calcula la matriz de probabilidad de acuerdo a lo establecido por la cadena de Markov para el individuo \(83\) para \(k=\{1,2,3,4\}\) y se generan tablas de contingencia.
# Paso 2: Calcular P^(k)_M manualmente
P_k1_M <- matriz_i_83
P_k2_M <- matriz_i_83 %*% matriz_i_83
P_k3_M <- matriz_i_83 %*% matriz_i_83 %*% matriz_i_83
P_k4_M <- matriz_i_83 %*% matriz_i_83 %*% matriz_i_83 %*% matriz_i_83
c_tabla1_k1M <- c_tabla(P_k1_M)
c_tabla1_k2M <- c_tabla(P_k2_M)
c_tabla1_k3M <- c_tabla(P_k3_M)
c_tabla1_k4M <- c_tabla(P_k4_M)c_tabla1_k1M s+k = 0 s+k = 1
s = 0 0.5185185 0.4814815
s = 1 0.7000000 0.3000000c_tabla1_k2M s+k = 0 s+k = 1
s = 0 0.6058985 0.3941015
s = 1 0.5729630 0.4270370c_tabla1_k3M s+k = 0 s+k = 1
s = 0 0.5900406 0.4099594
s = 1 0.5960178 0.4039822c_tabla1_k4M s+k = 0 s+k = 1
s = 0 0.5929185 0.4070815
s = 1 0.5918338 0.4081662Use una prueba \(\chi^2\) para comparar las matrices de probabilidades \(P^{(k)}\) y \(P^{(k)}_M\)
# Realiza la prueba de chi-cuadrado
chi_sq_test_1 <- chisq.test(c_tabla1, p = c_tabla1_k1M)
chi_sq_test_2 <- chisq.test(c_tabla2, p = c_tabla1_k2M)
chi_sq_test_3 <- chisq.test(c_tabla3, p = c_tabla1_k3M)
chi_sq_test_4 <- chisq.test(c_tabla4, p = c_tabla1_k4M)
chi_sq_test_1
Pearson's Chi-squared test with Yates' continuity correction
data: c_tabla1
X-squared = 7.5718e-33, df = 1, p-value = 1chi_sq_test_1
Pearson's Chi-squared test with Yates' continuity correction
data: c_tabla1
X-squared = 7.5718e-33, df = 1, p-value = 1chi_sq_test_3
Pearson's Chi-squared test with Yates' continuity correction
data: c_tabla3
X-squared = 7.5718e-33, df = 1, p-value = 1chi_sq_test_4
Pearson's Chi-squared test with Yates' continuity correction
data: c_tabla4
X-squared = 0, df = 1, p-value = 1Se plantea la siguiente hipotesis para comparar las matrices de probabilidades \(P^{(k)}\) y \(P^{(k)}_M\)
\[ H_0 : P^{(k)} = P^{(k)}_M \space \mbox{Vs} \space H_1: P^{(k)} \neq P^{(k)}_M \]
De los resultados obtenidos anteriormente se puede inferir no hay suficiente evidencia para rechazar la hipótesis nula, lo que sugiere que las matrices de probabilidades \(\mathbf{P}^{(k)}\) y \(\mathbf{P}^{(k)}_M\) son similares.