1. Revisar los datos

En la tabla de datos disponible aquí se encuentran datos de las estaturas de un grupo anterior de la especialización en estadística aplicada

2. Estimación de parámetros

Estime la media, desviación estándar de cada género y la proporción de hombres y mujeres del curso.

library(readxl)
library(dplyr)
library(tidyverse)
library(tigerstats)
df <- read_excel("taller3.xlsx") #Carga de los datos
df_hombres <- df %>% filter(df$Genero == 0) # Hombres
df_mujeres <- df %>%  filter(Genero == 1) # Mujeres

Media Hombres.

t.test(df_hombres$Estatura,var.equal = F,conf.level = 0.95)
## 
##  One Sample t-test
## 
## data:  df_hombres$Estatura
## t = 148.39, df = 15, p-value < 2.2e-16
## alternative hypothesis: true mean is not equal to 0
## 95 percent confidence interval:
##  171.5007 176.4993
## sample estimates:
## mean of x 
##       174

La estatura de los Hombres que estudian estadística aplicada se encuentra entre \((171.50 , 176.49)\) con un nivel de confianza del 95%.

Media mujeres:

t.test(df_mujeres$Estatura,var.equal = F,conf.level = 0.95)
## 
##  One Sample t-test
## 
## data:  df_mujeres$Estatura
## t = 78.471, df = 5, p-value = 6.368e-09
## alternative hypothesis: true mean is not equal to 0
## 95 percent confidence interval:
##  156.3707 166.9626
## sample estimates:
## mean of x 
##  161.6667

La estatura de las mujeres que cursan estadística aplicada se encuentra entre \((156.37,166.96)\) con un nivel de confianza del 95%

Varianza hombres:

'sd^2' = var(df_hombres$Estatura)
n=  length(df_hombres$Estatura)
alfhaMedios= 0.05/2
ls2 = round(((n-1)*`sd^2`)/qchisq(alfhaMedios,df = (n-1)),2) 
li2 =round(((n-1)*`sd^2`)/qchisq(1-alfhaMedios,df = (n-1)),2)
print(paste("limite inferior: ",li2," limite superior:",ls2))
## [1] "limite inferior:  12.01  limite superior: 52.7"

La varianza de los hombres se encuentra entre 12.01 y 52.7 con un nivel de confianza del 95%

Varianza Mujeres:

'sdm^2' = var(df_mujeres$Estatura)
nm=  length(df_mujeres$Estatura)
alfhaMedios= 0.05/2
lsm2 = round(((nm-1)*`sd^2`)/qchisq(alfhaMedios,df = (n-1)),2)
lim2 = round(((nm-1)*`sd^2`)/qchisq(1-alfhaMedios,df = (n-1)),2)
print(paste("limite inferior: ",lim2," limite superior:",lsm2))
## [1] "limite inferior:  4  limite superior: 17.57"

3. Hipótesis

Escriba la hipótesis nula y alternativa de la estatura de cada género con referencia al artículo del Tiempo.

\[ H_o: \mu = 176 \\ H_a: \mu < 176 \]

\[ H_o: \mu = 160 \\ H_a: \mu < 160 \]

Realizar los respectivos contrastes y concluir:

Para Hombres:

t.test(df_hombres$Estatura,mu = 176,var.equal = F,conf.level = 0.95,alternative = "l")
## 
##  One Sample t-test
## 
## data:  df_hombres$Estatura
## t = -1.7056, df = 15, p-value = 0.05435
## alternative hypothesis: true mean is less than 176
## 95 percent confidence interval:
##      -Inf 176.0556
## sample estimates:
## mean of x 
##       174

No existe evidencia suficiente para rechazar la hipótesis nula, sin embargo, podemos observar que nuestro p-valor fue de 0.054, cercano a nuestro nivel de significancia. Si aumentamos un 0.5% la probabilidad de cometer un error tipo I, es decir, trabajar con un nivel de significancia del 6% podríamos rechazar la hipótesis de que la estatura promedio del hombre es de 176 y aceptar la hipótesis alternativa, para concluir que la estatura promedio del hombre es menor a 1.76 de acuerdo a las muestras tomadas.

t.test(df_mujeres$Estatura,mu = 160,var.equal = F,conf.level = 0.95,alternative = "t")
## 
##  One Sample t-test
## 
## data:  df_mujeres$Estatura
## t = 0.80898, df = 5, p-value = 0.4553
## alternative hypothesis: true mean is not equal to 160
## 95 percent confidence interval:
##  156.3707 166.9626
## sample estimates:
## mean of x 
##  161.6667

No existe evidencia suficiente para rechazar la hipótesis nula, por lo tanto no podemos concluir si es verdadero o no.

4 .Hipótesis diferencia de estatura entre géneros

Ahora ponga a prueba la hipótesis de diferencia de altura de ambos géneros en el curso. para ver si la altura media de las mujeres es igual a la altura media de los hombres.

\[ H_o: \mu_H - \mu_M <= 0 \\ H_a: \mu_H - \mu_M > 0 \]

Concluya y escriba las consecuencias de la decisión

t.test(df_hombres$Estatura,df_mujeres$Estatura,alternative = "g",   var.equal = F,conf.level = 0.99)
## 
##  Welch Two Sample t-test
## 
## data:  df_hombres$Estatura and df_mujeres$Estatura
## t = 5.2028, df = 8.468, p-value = 0.0003418
## alternative hypothesis: true difference in means is greater than 0
## 99 percent confidence interval:
##  5.55662     Inf
## sample estimates:
## mean of x mean of y 
##  174.0000  161.6667

Podemos rechazar la hipotesis nula y aceptamos que los hombres tienen una altura mayor incluso con una probabilidad de cometer el error tipo I con 0.03% ,

5. Cáncer de mama

Considere el conjunto de datos en Kaggle sobre Datos reales sobre el cáncer de mama aquí

library(readr)
library(tidyverse)
BRCA <- read_csv("BRCA.csv")
glimpse(BRCA)
## Rows: 341
## Columns: 16
## $ Patient_ID         <chr> "TCGA-D8-A1XD", "TCGA-EW-A1OX", "TCGA-A8-A079", "TC…
## $ Age                <dbl> 36, 43, 69, 56, 56, 84, 53, 50, 77, 40, 71, 72, 75,…
## $ Gender             <chr> "FEMALE", "FEMALE", "FEMALE", "FEMALE", "FEMALE", "…
## $ Protein1           <dbl> 0.080353, -0.420320, 0.213980, 0.345090, 0.221550, …
## $ Protein2           <dbl> 0.426380, 0.578070, 1.311400, -0.211470, 1.906800, …
## $ Protein3           <dbl> 0.547150, 0.614470, -0.327470, -0.193040, 0.520450,…
## $ Protein4           <dbl> 0.273680, -0.031505, -0.234260, 0.124270, -0.311990…
## $ Tumour_Stage       <chr> "III", "II", "III", "II", "II", "III", "II", "III",…
## $ Histology          <chr> "Infiltrating Ductal Carcinoma", "Mucinous Carcinom…
## $ `ER status`        <chr> "Positive", "Positive", "Positive", "Positive", "Po…
## $ `PR status`        <chr> "Positive", "Positive", "Positive", "Positive", "Po…
## $ `HER2 status`      <chr> "Negative", "Negative", "Negative", "Negative", "Ne…
## $ Surgery_type       <chr> "Modified Radical Mastectomy", "Lumpectomy", "Other…
## $ Date_of_Surgery    <chr> "15-Jan-17", "26-Apr-17", "08-Sep-17", "25-Jan-17",…
## $ Date_of_Last_Visit <chr> "19-Jun-17", "09-Nov-18", "09-Jun-18", "12-Jul-17",…
## $ Patient_Status     <chr> "Alive", "Dead", "Alive", "Alive", "Dead", "Alive",…
theme_set(theme_bw())

Cambio de tipo de variable :

BRCA$Gender <- as.factor(BRCA$Gender )
BRCA$Tumour_Stage <- as.factor(BRCA$Tumour_Stage)
BRCA$Patient_Status <-as.factor(BRCA$Patient_Status)
BRCA$Surgery_type <- as.factor(BRCA$Surgery_type)

Cantidad de Nas por variables

(map_dbl(BRCA ,.f = function(x) sum(is.na(x))))
##         Patient_ID                Age             Gender           Protein1 
##                  7                  7                  7                  7 
##           Protein2           Protein3           Protein4       Tumour_Stage 
##                  7                  7                  7                  7 
##          Histology          ER status          PR status        HER2 status 
##                  7                  7                  7                  7 
##       Surgery_type    Date_of_Surgery Date_of_Last_Visit     Patient_Status 
##                  7                  7                 24                 20

Age

Estadísticos generales:

summary(BRCA$Age)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.    NA's 
##   29.00   49.00   58.00   58.89   68.00   90.00       7
qden <- BRCA %>% drop_na() %>% ggplot(aes(x=Age,fill="orange")) + geom_density(show.legend = F,alpha=0.8)+ggtitle("Curva de densidad para la variable Age")
qden

La variable edad tiende a tener una distribución normal, esto lo podemos comprobar con una prueba de hipótesis.

shapiro.test(BRCA$Age)
## 
##  Shapiro-Wilk normality test
## 
## data:  BRCA$Age
## W = 0.98185, p-value = 0.0003175
q1<-BRCA %>% drop_na() %>% filter(Tumour_Stage =="I") %>% 
ggplot(aes(x=Age,fill=Patient_Status))+geom_density(alpha=0.5)+ggtitle("Tumour Stage I")


q2<-BRCA %>% drop_na() %>% filter(Tumour_Stage =="II") %>% 
ggplot(aes(x=Age,fill=Patient_Status))+geom_density(alpha=0.5)+ggtitle("Tumour Stage II")

q3<-BRCA %>% drop_na() %>% filter(Tumour_Stage =="III") %>% 
ggplot(aes(x=Age,fill=Patient_Status))+geom_density(alpha=0.5)+ggtitle("Tumour Stage III")

library(patchwork)

(q1/q2/q3)

Podemos observar que el comportamiento de la edad respecto a la etapa del tumor es distinta en cada una, cuando el tumor está en etapa I las edades en donde las personas tienden a perder la vida están entre los 30 - 40 años y de 80 en adelante.

Cuando se presenta un tumor etapa II e inician el tratamiento es más frecuente que las personas entre los 55 a 75 años pierden la vida.

Las edades entre 45 y 55 años donde se comenzó un tratamiento cuando el tumor está en etapa III son más propensas a perder la vida.

Según las gráficas se podría pensar que es similar la proporción de personas que pierden la vida cuando comienzan el tratamiento en etapa II y III.

Surgery_type (Tipo cirugia)

Las cirugias realizadas se categorizaron en Lumpectomy, Modified Radical Mastectomy, Simple Mastectomy y other.

levels(BRCA$Surgery_type)
## [1] "Lumpectomy"                  "Modified Radical Mastectomy"
## [3] "Other"                       "Simple Mastectomy"

De las 341 observaciones 7 son valores ausentes, la cateogria con mas cirugias realizas fueron “other”.

summary(BRCA$Surgery_type)
##                  Lumpectomy Modified Radical Mastectomy 
##                          66                          96 
##                       Other           Simple Mastectomy 
##                         105                          67 
##                        NA's 
##                           7
ggplot(BRCA,aes(x=BRCA$Surgery_type,fill=Surgery_type)) + geom_bar(show.legend = F)+ggtitle("Surgery type")+xlab("Surgery type")

De acuerdo al siguiente grafico, podemos observar que la proporción de persona que conservan la vida con cancer de mama al ser operadas por Lumpectomy es mayor a la proporción de personas que la pierden.

ggplot(BRCA,aes(x=Surgery_type,fill=Patient_Status)) + geom_bar()+ggtitle("Surgery type  ")+xlab("Surgery_type")+labs(fill="Type")

Podríamos hacer una prueba de hipótesis para cada afirmación presentada anteriormente, puesto que en algunos casos puede que la evidencia presentada no sea suficiente para afirmar o refutar estas afirmaciones.

Una posible hipótesis sería intentar determinar que tipo de cirugía tiene mayor éxito para tratar este cáncer.

La proporción de personas que sobreviven con “Lumpectomy” es mayor a la proporción de “Other”.

\[H_o=P_{lumpectomy}-P_{other}<=0 \\ H_a = P_{lumpectomy}-P_{other} >0\]

Tabla1 <- BRCA %>% filter(Surgery_type == c("Other", "Lumpectomy"))
## Warning in `==.default`(Surgery_type, c("Other", "Lumpectomy")): longer object
## length is not a multiple of shorter object length
## Warning in is.na(e1) | is.na(e2): longer object length is not a multiple of
## shorter object length
Tabla1$Surgery_type <- as.character(Tabla1$Surgery_type)
Tabla1$Surgery_type <- as.factor(Tabla1$Surgery_type)
levels(Tabla1$Surgery_type)
## [1] "Lumpectomy" "Other"
Tabla2 <- table(Tabla1$Surgery_type,Tabla1$Patient_Status)
Tabla2
##             
##              Alive Dead
##   Lumpectomy    29    5
##   Other         37   13

Proporcion Alive Lumpectomy = 0.85 , Proporcion Other = 0.74

proptestGC(x=c(29,37),conf.level = 0.95,n = c(34,50),alternative = "g",p = 0)
## 
## 
## Inferential Procedures for the Difference of Two Proportions p1-p2:
##  Results taken from summary data.
## 
## 
## Descriptive Results:
## 
##         successes  n estimated.prop
## Group 1        29 34         0.8529
## Group 2        37 50         0.7400
## 
## 
## WARNING:  In at least one of the two groups
## number of successes or number of failures is below 10.
## The normal approximation for confidence intervals
## and P-value may be unreliable.
## 
## Inferential Results:
## 
## Estimate of p1-p2:    0.1129 
## SE(p1.hat - p2.hat):  0.08682 
## 
## 95% Confidence Interval for p1-p2:
## 
##           lower.bound         upper.bound          
##           -0.029860           1.000000             
## 
## Test of Significance:
## 
##  H_0:  p1-p2 = 0
##  H_a:  p1-p2 > 0
## 
##  Test Statistic:     z = 1.301 
##  P-value:        P = 0.09664

No se tiene evidencia suficiente para confirmar o refutar las hipótesis, sin embargo, si la probabilidad de caer en el error tipo I fuera del 10% podríamos rechazar la hipótesis nula y aceptar que la proporción de personas que se salvan al someterse a la cirugía Lumpectomy es mayor a las que se someten a Others