Trabalho I - Análise de Dados Categóricos


Vitor Nickhorn Kroeff

GRR20195798

Questão 1

a)

  1. Existirem n tentativas idênticas.
  2. Existirem dois resultados possíveis para cada tentativa.
  3. Tentativas indepêndentes entre si.
  4. Probabilidade de sucesso constante para cada tentativa.
  5. A variável de interesse é o número de sucessos.

b)

Usaremos o IC deAgresti-Coull:

# Agresti-Coull
n <- 750
s <- 48
alpha <- 0.05

kable(binom.confint(x = s, n = n, conf.level = 1-alpha, methods = "agresti-coull"))
method x n mean lower upper
agresti-coull 48 750 0.064 0.0484705 0.0839731

Considerando que a nossa estimativa $ = 0,064$ e é um valor relativamente baixo, o intervalo de confiança de 95% para esta proporção varia entre 0,05 e 0,08.

Questão 2

a)

Sensibilidade: proporção de indivíduos verdadeiramente positivos com teste positivo.

Especificidade: proporção de indivíduos verdadeiramente negativos com teste negativo.

aptima <- read.table(file = 'http://leg.ufpr.br/~lucambio/CE073/20222S/Aptima_combo.csv', header = TRUE, sep = ',')

c.table <- array(data = c(aptima[1,6], aptima[1,7], 
                          aptima[1,9], aptima[1,8]), dim = c(2,2),
                          dimnames = list(True = c("+", "-"), Assay = c("+", "-")))

Se.hat <- c.table[1,1] / sum(c.table[1,])
Sp.hat <- c.table[2,2] / sum(c.table[2,])

data.frame(Se.hat, Sp.hat)
##     Se.hat    Sp.hat
## 1 0.964467 0.9686848
w1 <- c.table[1,1]
w2 <- c.table[2,2]
n1 <- sum(c.table[1,])
n2 <- sum(c.table[2,])

kable(binom.confint(x = c(w1,w2), n = c(n1,n2), conf.level = 1-alpha, methods = "exact"))
method x n mean lower upper
exact 190 197 0.9644670 0.9281616 0.9855967
exact 464 479 0.9686848 0.9488757 0.9823693

A proporção estimada de indivíduos que são verdadeiramente positivos e obtêm um resultado positivo no teste é de 0,96. Para aqueles que são verdadeiramente negativos e recebem um resultado negativo no teste, a proporção é de aproximadamente 0,97. Com um nível de confiança de 95%, o intervalo de confiança para a primeira proporção varia entre 0,93 e 0,98, enquanto para a segunda, varia entre 0,95 e 0,98.

b)

Para calcular os intervalos de Clopper-Pearson, com um nível de significância de \(\alpha = 0,05\), para as outras combinações de doença, gênero, espécime e sintoma da tabela Aptima, foram construidas duas tabelas, a tabela Sensibilidade a tabela Especificidade. Em ambos os casos, as proporções estimadas, juntamente com os limites dos intervalos, são notavelmente elevadas, o que indica uma alta incidência de verdadeiros positivos e verdadeiros negativos

aptima$Se.hat <- aptima$True_positive / (aptima$True_positive + aptima$False_negative)

aptima$Sp.hat <- aptima$True_negative / (aptima$False_positive + aptima$True_negative)

sensibilidade <- binom.confint(x = aptima$True_positive, n = (aptima$True_positive + aptima$False_negative), conf.level = (1 - alpha), methods = "exact")
  
especificidade <- binom.confint(x = aptima$True_negative, n = (aptima$False_positive + aptima$True_negative), conf.level = (1 - alpha), methods = "exact")

kable(sensibilidade)
method x n mean lower upper
exact 190 197 0.9644670 0.9281616 0.9855967
exact 70 74 0.9459459 0.8673449 0.9850777
exact 199 202 0.9851485 0.9572134 0.9969267
exact 77 80 0.9625000 0.8942980 0.9921988
exact 133 144 0.9236111 0.8674307 0.9612511
exact 61 62 0.9838710 0.9133790 0.9995917
exact 136 145 0.9379310 0.8854450 0.9712281
exact 60 62 0.9677419 0.8882809 0.9960692
exact 304 307 0.9902280 0.9717093 0.9979802
exact 15 15 1.0000000 0.7819806 1.0000000
exact 311 316 0.9841772 0.9634632 0.9948429
exact 13 13 1.0000000 0.7529474 1.0000000
exact 94 94 1.0000000 0.9615166 1.0000000
exact 31 32 0.9687500 0.8378290 0.9992091
exact 87 94 0.9255319 0.8525702 0.9695365
exact 28 32 0.8750000 0.7100516 0.9648693
kable(especificidade)
method x n mean lower upper
exact 464 479 0.9686848 0.9488757 0.9823693
exact 309 314 0.9840764 0.9632329 0.9948100
exact 484 492 0.9837398 0.9682134 0.9929545
exact 316 320 0.9875000 0.9683060 0.9965840
exact 653 675 0.9674074 0.9510687 0.9794639
exact 501 507 0.9881657 0.9744206 0.9956450
exact 668 676 0.9881657 0.9768154 0.9948773
exact 502 507 0.9901381 0.9771366 0.9967903
exact 412 417 0.9880096 0.9722415 0.9960956
exact 351 363 0.9669421 0.9429670 0.9828041
exact 433 434 0.9976959 0.9872295 0.9999417
exact 368 370 0.9945946 0.9806112 0.9993447
exact 772 787 0.9809403 0.9687585 0.9892942
exact 562 564 0.9964539 0.9872495 0.9995703
exact 782 789 0.9911280 0.9818062 0.9964258
exact 564 567 0.9947090 0.9846159 0.9989075

Questão 3

c.table <- array(data = c(135, 15, 434, 9), dim = c(2, 2), 
                 dimnames = list(Preservativo = c('Nunca', 'Sempre'), HIV = c('Positivo', 'Negativo')))
kable(c.table)
Positivo Negativo
Nunca 135 434
Sempre 15 9

a)

Podemos observar que o intervalo de confiança de 95% de Wald apresentou um ligeiro deslocamento para a esquerda em comparação ao intervalo de Agresti-Caffo. No teste de Wald, podemos observar que a diferença entre as probabilidades de ser HIV positivo com base no uso de preservativo está entre -0,58 e -0,19, enquanto no segundo está entre -0,57 e -0,19.

# Wald
pi.hat.table <- c.table / rowSums(c.table)

alpha <- 0.05
pi.hat1 <- pi.hat.table[1,1]
pi.hat2 <- pi.hat.table[2,1]

var.wald <- pi.hat1 * (1 - pi.hat1) / sum(c.table[1,]) + pi.hat2 * (1 - pi.hat2) / sum(c.table[2,])

pi.hat1 - pi.hat2 + qnorm(p = c(alpha/2, 1 - alpha/2)) * sqrt(var.wald)
## [1] -0.5845563 -0.1909270
# Agresti-Caffo
pi.tilde1 <- (c.table[1,1] + 1) / (sum(c.table[1,]) + 2)
pi.tilde2 <- (c.table[2,1] + 1) / (sum(c.table[2,]) + 2)

var.AC <- pi.tilde1 * (1 - pi.tilde1) / (sum(c.table[1,]) + 2) +
          pi.tilde2 * (1 - pi.tilde2) / (sum(c.table[2,]) + 2)

pi.tilde1 - pi.tilde2 + qnorm(p = c(alpha/2, 1 - alpha/2)) * sqrt(var.AC)
## [1] -0.5674447 -0.1869673

b)

A saída a seguir apresenta uma estatística de teste \(Z^2_{0}\) de 18,322 e um p-valor muito pequeno, com isso rejeitamos a hipótese nula.

# Teste Escore e Teste Qui-Quadrado de Pearson

prop.test(c.table, conf.level = 0.95, correct = FALSE)
## 
##  2-sample test for equality of proportions without continuity correction
## 
## data:  c.table
## X-squared = 18.322, df = 1, p-value = 1.866e-05
## alternative hypothesis: two.sided
## 95 percent confidence interval:
##  -0.5845563 -0.1909270
## sample estimates:
##    prop 1    prop 2 
## 0.2372583 0.6250000

Assim como o teste acima, o LRT apresenta a mesma conclusão. Nesse teste também é estimado um \(\hat{\pi}= 0,253\).

# LRT
pi.bar <- colSums(c.table)[1] / sum(c.table)

log.lambda <- c.table[1,1] * log(pi.bar / pi.hat.table[1,1]) +
              c.table[1,2] * log((1 - pi.bar) / (1 - pi.hat.table[1,1])) +
              c.table[2,1] * log(pi.bar / pi.hat.table[2,1]) + 
              c.table[2,2]

test.stat <- -2 * log.lambda
crit.val <- qchisq(p = 0.95, df = 1)
p.val <- 1 - pchisq(q = test.stat, df = 1)

round(data.frame(pi.bar, test.stat, crit.val, p.val, row.names = NULL), 4)
##   pi.bar test.stat crit.val  p.val
## 1  0.253    9.8887   3.8415 0.0017

c)

Encontramos uma razão de chances de 0,19, o que significa que as chances estimadas de contrair o HIV são 0,19 vezes menores com o uso do preservativo. Esse valor varia entre 0,08 e 0,44 com um intervalo de confiança de 95%. Uma vez que o valor 1 não está dentro deste intervalo, existem evidências suficientes para indicar que o uso do preservativo reduz significativamente as verdadeiras chances e, consequentemente, a probabilidade de contrair o HIV.

OR.hat <- c.table[1,1] * c.table[2,2] / (c.table[2,1] * c.table[1,2])

round(OR.hat, 2)
## [1] 0.19
alpha <- 0.05

var.log.or <- 1 / c.table[1,1] + 1/c.table[1,2] + 1/c.table[2,1] +
  1/c.table[2,2]

OR.CI <- exp(log(OR.hat) + qnorm(p = c(alpha/2, 1-alpha/2)) * sqrt(var.log.or))

round(OR.CI, 2)
## [1] 0.08 0.44

d)

Após analisar a alternativa anterior, que apontou a relação entre o uso do preservativo e a redução da probabilidade de contrair o HIV, é importante destacar que a estimativa da razão de chances resultou em um valor relativamente baixo. O limite inferior do intervalo de confiança foi de 0,08, o que representa uma probabilidade relativamente pequena.

Sob uma perspectiva estatística, considerando o tamanho limitado da amostra, os resultados indicam que o impacto do uso do preservativo pode não ser tão marcante quanto inicialmente esperado. Seria aconselhável realizar análises adicionais em amostras mais amplas, com um número maior de casos, para obter resultados mais robustos e conclusivos.

Questão 4

Embora o intervalo calculado pela função diffscoreci mostre um desvio ligeiramente menor em comparação com os outros intervalos, é importante notar que todos os três intervalos incluem o valor 0. Esse fato contribui para a não rejeição da hipótese nula.

c.table <- array(data = c(251,48,34,5), dim = c(2,2), dimnames = list(First = c("made", "missed"), Second = c("made", "missed")))

diffscoreci(c.table[1,1], c.table[1,1] + c.table[1,2], c.table[2,1], c.table[2,1] + c.table[2,2], conf.level = 1 - alpha)
## 
## 
## 
## data:  
## 
## 95 percent confidence interval:
##  -0.09529146  0.08792491
# Wald
pi.hat.table <- c.table/rowSums(c.table)
pi.hat1 <- pi.hat.table[1 ,1]
pi.hat2 <- pi.hat.table[2 ,1]
var.wald <- pi.hat1*(1 - pi.hat1) / sum(c.table[1,]) +
            pi.hat2*(1 - pi.hat2) / sum(c.table[2 ,])
pi.hat1 - pi.hat2 + qnorm (p = c( alpha/2, 1- alpha/2))*sqrt(var.wald )
## [1] -0.11218742  0.06227017
# Agresti-Caffo
pi.tilde1 <- (c.table[1,1] + 1) / (sum(c.table[1 ,]) + 2)
pi.tilde2 <- (c.table [2,1] + 1) / (sum(c.table [2 ,]) + 2)
var.AC <- pi.tilde1*(1 - pi.tilde1 ) / (sum(c.table [1 ,]) + 2) + 
          pi.tilde2*(1 - pi.tilde2 ) / (sum(c.table [2 ,]) + 2)
pi.tilde1 - pi.tilde2 + qnorm (p = c( alpha /2, 1- alpha /2)) * sqrt (var.AC)
## [1] -0.10353254  0.07781192

Questão 5

Mostre que OR= 1 quando \(\pi_{1} = \pi_{2}\).

se \(\pi_{1} = \pi_{2}\), então: \[OR = odds_{1} / odds_2 = \frac{\pi_1/ 1 -\pi_1 }{\pi_2/ 1 -\pi_2 } = 1\]