Análise de tabelas 2 x 2

<?xml version="1.0" encoding="ISO-8859-1"?>
<Rscript>
<titulo>Análise de tabelas 2 x 2</titulo>
<descricao>
Cálculo de percentagens, risco relativo, odds ratio e qui-quadrado e gráficos para tabelas 2x2.
</descricao>
<autor>Ernani B Bandarra e Oswaldo G Cruz</autor>
<email>Bandarra@datasus.gov.br / oswaldo@fiocruz.br</email>
<versao>1.0</versao>
<parametro></parametro>
<parametro2></parametro2>
<colsel></colsel>
<colsel2></colsel2>
<script>
if (version$minor > "8.1") { 
	library(stats)
	library(graphics)
      
}

tabular <- function(x,  conf=0.95) {
	tmp <- list()
	
	if (dim(x)[1]!=2 || dim(x)[2] !=2) {
		stop(" x tem de ser Matrix 2x2 ")
		}	
	
	total <- sum(x)
	rowsum <- apply(x,1,sum)
	colsum <- apply(x,2,sum)
	pcttotal <- x/total
	pctlinha <- sweep(x,1,rowsum,"/")
	pctcoluna <- sweep(x,2,colsum,"/")
	experado <- (matrix(rowsum) %*% t(matrix(colsum))) / total
	dimnames(experado) <- dimnames(x)
	
	
	or <- x[1,1] * x[2,2] / ( x[2,1] * x[1,2] )
	ASE.or <- sqrt(sum(1/x))
	IC.or <- exp(log(or) + c(-1,1) * qnorm(0.5*(1+conf)) *ASE.or )
	
	p1 <- x[1,1]/sum(x[1,]) 
	p0 <- x[2,1]/sum(x[2,])

	rr <- p1/p0
	diff = (p1-p0)*100

	ASE.rr <- sqrt( (1-p1)/sum(x[1,]*p1) + (1-p0)/(sum(x[2,]*p0) )) 

	IC.rr <- exp(log(rr) + c(-1,1) * qnorm(0.5*(1+conf)) *ASE.rr )
	
	
	x2 <- chisq.test(x)
	
	
	tmp <- list(or=or,ASE.or=ASE.or,intervalo.or=IC.or,
	            rr=rr,ASE.rr=ASE.rr,intervalo.rr=IC.rr,diff.rr=diff,
	            x2.quad=x2$statistic,x2.pval=x2$p.value,x2.gl=x2$parameter,
	            x2.metodo=x2$method,conf=conf,
	            tab=x,pcttotal=pcttotal,pctlinha=pctlinha,pctcoluna=pctcoluna,experado=experado)
		
	class(tmp) <- "tabela"
	tmp
}

plot.tabela <- function(obj,cor=c("red","orange","green","yellow"),borda=F) {

	x <- obj$tab
	a <- rep(NULL,4)
	cborda <- rep("black",4)
			
	if (borda==F) cborda <- cor
	
	
	a<- c(x[1,1],x[1,2],x[2,2],x[2,1])
	b <- sqrt(a)
	z <- sum(b) / 2 
	old.par <- par(no.readonly = TRUE)
	par(pty="s")
	plot(c(1,2*z),c(1,2*z), type = "n", xlab=names(x)[1], ylab=rownames(x)[1])
	
	polygon(c(z-b[1],z,z,z-b[1]), c(z+b[1],z+b[1],z,z), col=cor[1],  border = cborda[1])
	polygon(c(z+b[2],z,z,z+b[2]), c(z+b[2],z+b[2],z,z), col=cor[2],  border = cborda[2])
	polygon(c(z+b[3],z,z,z+b[3]), c(z-b[3],z-b[3],z,z), col=cor[3],  border = cborda[3])
	polygon(c(z-b[4],z,z,z-b[4]), c(z-b[4],z-b[4],z,z), col=cor[4],  border = cborda[4])
	title(paste(titulo,"\n",subtitulo))
	par(old.par)
}

print.tabela  <- function(x,digitos=4) {
	cat ("\n\n  Resultados para a tabela ",titulo,"\n\n")
#	cat (titulo,"\n")
	cat (subtitulo,"\n")
	cat ("\nTabela \n\n")
	print(x$tab) 
	cat ("\nPercentagem Total \n\n")
	print(x$pcttotal,digits=digitos)
	cat ("\nPercentagem na Linha \n\n")
	print(x$pctlinha,digits=digitos)
	cat ("\nPercentagem Coluna \n\n")
	print(x$pctcoluna,digits=digitos)
	cat ("\nValor Esperado \n\n")
	print(x$experado,digits=digitos)
	
	cat ("\n\nRisco Relativo  \n\n")
	cat ("\n valor do Risco Relativo =", x$rr,"\n")
	cat ("\n Intervalo de Confiança (", x$conf,"%) \t", x$intervalo.rr[1],"   a   ",x$intervalo.rr[2], "\n", sep="" )
	cat ("\n Diferença de Risco     =", x$diff.rr,"%\n")
	
	cat ("\n\nOdds Ratio  \n\n")
	cat ("\n valor do Odds Ratio =", x$or,"\n")
	cat ("\n Intervalo de Confiança (",x$conf,"%) \t",x$intervalo.or[1],"   a   ",x$intervalo.or[2], "\n", sep="" )
	
	cat ("\n\nQui Quadrado  \n\n")
	cat(" Qui Quadrado       = ",x$x2.quad,"\n")
	cat(" Valor p            = ",x$x2.pval,"\n")
	cat(" Graus de liberdade = ",x$x2.gl,"\n")
	cat(" Método             = ",x$x2.metodo,"\n")
 	cat("\n\n")
	
	
}

tabela = tabela[1:2]	
saida <- tabular(tabela)
grafico.tabwin()
plot(saida)
saida
</script>
<exemplo>

</exemplo>
</Rscript>