In jtrecenti/adocao:
Descritiva - CNA - Crianças Disponíveis
Banco de dados passado pelo CNJ no dia 05/09/2013.
require(ggplot2)
require(stringr)
require(plyr)
require(reshape2)
require(lubridate)
theme.st <- theme_bw() +
theme(axis.title.x=element_text(size=16),
axis.title.y=element_text(size=16),
axis.text.x=element_text(size=16, hjust=0.5),
axis.text.y=element_text(size=16),
legend.title=element_text(size=16),
legend.text=element_text(size=16),
strip.text.x = element_text(angle=0, size=16),
strip.text.y = element_text(angle=-90, size=16))
theme.boxplot.uni <- theme(axis.title.y=element_blank(),
axis.title.x=element_text(size=16),
axis.text.y=element_blank(),
axis.text.x=element_text(size=16),
axis.ticks.y=element_blank(),
legend.title=element_text(size=16),
legend.text=element_text(size=16))
theme.boxplot.bi <- theme(axis.title.x=element_blank(),
axis.title.y=element_text(size=16),
axis.text.x=element_text(size=12, angle=90, hjust=1, vjust=0.5),
axis.text.y=element_text(size=16),
axis.ticks.x=element_blank(),
legend.title=element_text(size=16),
legend.text=element_text(size=16))
# Carregando e limpando CSV
cna_disp <- read.csv2('/home/CNJ/CNA/bd/cna_crianca_disp.csv', as.is=T)
#names(cna_disp)
cna_disp$data_disponibilizacao_num <- as.POSIXlt(cna_disp$DT.Disponibilização.Criança, format='%d/%m/%Y')
cna_disp$ano_disponibilizacao_num <- cna_disp$data_disponibilizacao_num$year + 1900
cna_disp$data_nascimento_num <- as.POSIXlt(cna_disp$data_nascimento, format='%d/%m/%Y')
#View(cna_disp[!is.na(cna_disp$ano_disponibilizacao_num) & cna_disp$ano_disponibilizacao_num < 1990,])
cna_disp$data_ultima_alteracao <- as.POSIXlt(cna_disp$Ult.Alteração, format='%d/%m/%Y %H:%M')
cna_disp_limpo <- cna_disp[!is.na(cna_disp$ano_disponibilizacao_num) &
cna_disp$ano_disponibilizacao_num >= 2000 &
cna_disp$ano_disponibilizacao_num < 2014,]
# # verifica se ano_disponibilizacao_num e Ano.Disp.Adoção são a mesma coisa
# summary(with(cna_disp_limpo, ano_disponibilizacao_num - Ano.Disp.Adoção))
# table(is.na(cna_disp_limpo$ano_disponibilizacao_num),is.na(cna_disp_limpo$Ano.Disp.Adoção))
Retirada de r sum(is.na(cna_disp$data_disponibilizacao_num)) obs do BD por não ter informação da data de disponibilização.
Análise descritiva das crianças disponíveis
Com que idade as crianças ficaram disponíveis?
cna_disp_limpo$idade_disponibilizacao <- as.numeric(with(cna_disp_limpo, data_disponibilizacao_num - data_nascimento_num)/60/60/24/365)
cna_disp_limpo <- cna_disp_limpo[cna_disp_limpo$idade_disponibilizacao >=0 & cna_disp_limpo$idade_disponibilizacao <=18,]
Graficos exploratorios
ggplot(cna_disp_limpo, aes(x=idade_disponibilizacao)) +
geom_histogram(aes(y=..density..), color='black', fill='white')+
scale_x_continuous(breaks=0:18) +
theme_bw()
ggplot(cna_disp_limpo, aes(x=idade_disponibilizacao)) +
geom_histogram(aes(y=..density.., fill=situacao_crianca))+
scale_x_continuous(breaks=0:18) +
theme_bw()
totais <- as.data.frame(table(cna_disp_limpo$situacao_crianca))
totais$n <- paste('n =', totais$Freq)
totais$x <- 18
totais$y <- .5
ggplot(cna_disp_limpo, aes(x=idade_disponibilizacao, group=situacao_crianca)) +
geom_histogram(aes(y=..density..), color='black', fill='white') +
geom_text(data=totais, aes_string(x='x', y='y', label='n', group='Var1'), colour="black")+
facet_wrap(~situacao_crianca) +
labs(x='Idade de Disponibilização', y='Densidade') +
theme_bw()
#quantile(cna_disp_limpo$idade_disponibilizacao[cna_disp_limpo$situacao_crianca %in% "Disponivel"],probs=c(0,0.15,1))
ggplot(cna_disp_limpo, aes(x=situacao_crianca, y=idade_disponibilizacao)) +
geom_boxplot() +
theme_bw()
for(i in names(cna_disp_limpo)) {
print(i)
print(table(cna_disp_limpo[[i]]))
}
Qual é o destino de crianças para cada faixa etária?
breaks <- c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,17,Inf)
cna_disp_limpo$faixa_etaria_disponibilizacao <- cut(cna_disp_limpo$idade_disponibilizacao, breaks=breaks, include.lowest=T)
levs <- levels(cna_disp_limpo$faixa_etaria_disponibilizacao)
levels(cna_disp_limpo$faixa_etaria_disponibilizacao) <- c(levs[-length(levs)], '18 anos')
cna_disp_limpo$situacao_crianca2 <- factor(cna_disp_limpo$situacao_crianca)
levels(cna_disp_limpo$situacao_crianca2) <- c("Adotada", "Adotada", "Adotada", "Adoção em andamento", 'Maioridade', 'Disponível', 'Adoção em andamento', 'Faleceu', 'Consulta', 'Censura', 'Consulta','Censura')
cna_disp_limpo$situacao_crianca3 <- factor(cna_disp_limpo$situacao_crianca)
levels(cna_disp_limpo$situacao_crianca3) <- c("Adotada", "Adotada", "Adotada", "Outros", 'Maioridade', 'Disponível', 'Outros', 'Outros', 'Outros', 'Outros', 'Outros','Outros')
tab <- with(cna_disp_limpo, table(situacao_crianca3,faixa_etaria_disponibilizacao))
tab_df <- merge(tab, prop.table(tab,2), by=c('situacao_crianca3', 'faixa_etaria_disponibilizacao'))
tab_df <- merge(tab_df, data.frame(margin.table(tab,2)), by='faixa_etaria_disponibilizacao')
tab_df$situacao_crianca3 <- as.character(tab_df$situacao_crianca3)
ggplot(tab_df, aes(x=faixa_etaria_disponibilizacao, y=Freq.y*100, group=situacao_crianca3, colour=situacao_crianca3)) +
geom_point() +
geom_line() +
geom_text(aes(x=faixa_etaria_disponibilizacao, y=80, label=Freq), color="black", alpha=.1, size=5) +
labs(x='Idade de disponibilização (anos)', y='%', colour='Situação atual da criança') +
theme.st
Analise dos 965 que atingiram maioridade
cna_disp_limpo_maior <- cna_disp_limpo[cna_disp_limpo$situacao_crianca %in% "Atingiu Maioridade",]
cna_disp_limpo_nmaior <- cna_disp_limpo[!cna_disp_limpo$situacao_crianca %in% "Atingiu Maioridade",]
tab_df <- data.frame(prop.table(table(cna_disp_limpo_maior$UF.abrigo)))
tab_df2 <- data.frame(prop.table(table(cna_disp_limpo_nmaior$UF.abrigo)))
tab_df_tot <- merge(tab_df2,tab_df,by='Var1', all.x=T)
names(tab_df_tot) <- c('UF', 'prop_brasil', 'prop_maior')
pchisq(sum((tab_df_tot$prop_maior-tab_df_tot$prop_brasil)^2/tab_df_tot$prop_brasil, na.rm=T),df=26,lower.tail=F)
tab_df <- data.frame(prop.table(table(cna_disp_limpo_maior$faixa_etaria_disponibilizacao)))
tab_df2 <- data.frame(prop.table(table(cna_disp_limpo_nmaior$faixa_etaria_disponibilizacao)))
tab_df_tot <- merge(tab_df2,tab_df,by='Var1', all.x=T)
names(tab_df_tot) <- c('UF', 'prop_brasil', 'prop_maior')
pchisq(sum((tab_df_tot$prop_maior-tab_df_tot$prop_brasil)^2/tab_df_tot$prop_brasil, na.rm=T),df=nrow(tab_df_tot)-1,lower.tail=F)
teste <- function(var) {
tab_df <- data.frame(table(cna_disp_limpo_maior[[var]]))
tab_df2 <- data.frame(prop.table(table(cna_disp_limpo_nmaior[[var]]))*(sum(tab_df$Freq)))
tab_df_tot <- merge(tab_df2,tab_df,by='Var1', all.x=T)
names(tab_df_tot) <- c(var, 'prop_brasil', 'prop_maior')
chisquare <- sum((tab_df_tot$prop_maior-tab_df_tot$prop_brasil)^2/tab_df_tot$prop_brasil, na.rm=T)
vp <- pchisq(chisquare,df=nrow(tab_df_tot)-1,lower.tail=F)
return(list(tab_df_tot, vp))
}
(df_testes <- lapply(names(cna_disp_limpo)[c(7:13,15:33,38)],teste))
df_testes[sapply(df_testes, function(x) x[[2]] < 1e-10)]
addmargins(round(prop.table(table(cna_disp_limpo$faixa_etaria_disponibilizacao, cna_disp_limpo$entrega_voluntaria),2)*100,2),1)
addmargins(round(prop.table(table(cna_disp_limpo$faixa_etaria_disponibilizacao, cna_disp_limpo$obito_dos_pais),2)*100,2),1)
Idade de disponibilizacao vs origem
compara <- function(variavel, label=variavel) {
totais <- as.data.frame(table(cna_disp_limpo[[variavel]]))
totais$n <- paste('n =', totais$Freq)
totais$x <- 16
totais$y <- .15
totais[[variavel]] <- as.character(totais$Var1)
cna_disp_limpo[[variavel]] <- as.character(cna_disp_limpo[[variavel]])
ggplot(cna_disp_limpo, aes_string(x='idade_disponibilizacao', group=variavel)) +
geom_histogram(aes(y=..density..), color='black', fill='white', binwidth=1) +
facet_wrap(as.formula(paste('~',variavel))) +
geom_text(data=totais, aes_string(x='x', y='y', label='n', group=variavel), colour="black")+
scale_x_continuous(breaks=0:18) +
labs(x='Idade de Disponibilização', y='Densidade', title=label) +
theme_bw()
}
totais <- as.data.frame(table(cna_disp_limpo$situacao_crianca))
totais$n <- paste('n =', totais$Freq)
totais$x <- 16
totais$y <- .5
totais$situacao_crianca <- totais$Var1
ggplot(cna_disp_limpo, aes(x=idade_disponibilizacao, group=situacao_crianca)) +
geom_histogram(aes(y=..density..), color='black', fill='royalblue', binwidth=1, alpha=.8) +
facet_wrap(~situacao_crianca) +
geom_text(data=totais, aes_string(x='x', y='y', label='n', group='situacao_crianca'), colour="black")+
scale_x_continuous(breaks=seq(0,18,by=2)) +
labs(x='Idade de Disponibilização', y='Densidade') +
theme_bw() +
theme(strip.text.x=element_text(size=12),
axis.text=element_text(size=11),
axis.title=element_text(size=14))
total <- data.frame(nrow(cna_disp_limpo), n=paste('n =',nrow(cna_disp_limpo)), x=15, y=0.14)
ggplot(cna_disp_limpo, aes(x=idade_disponibilizacao)) +
geom_histogram(aes(y=..density..), color='black', fill='lightblue', binwidth=.5, alpha=.1) +
geom_text(data=total, aes_string(x='x', y='y', label='n'), colour="black")+
scale_x_continuous(breaks=seq(0,18,by=1)) +
labs(x='Idade de Disponibilização', y='Densidade') +
theme_bw() +
theme(strip.text.x=element_text(size=12),
axis.text=element_text(size=11),
axis.title=element_text(size=14))
p1 <- compara('obito_dos_pais')
p2 <- compara('descumprimento_injustificado_reiterado_dos_deveres_do_poder_familiar')
p3 <- compara('ambiente_contrario_a_moral_e_bons_costumes')
p4 <- compara('pais_desconhecidos')
p5 <- compara('entrega_voluntaria')
p6 <- compara('abandono')
source('multiplot.R')
multiplot(p1,p2,p3,p4,p5,p6, cols=2)
compara2 <- function(variavel, label=variavel) {
totais <- as.data.frame(table(cna_disp_limpo[[variavel]]))
totais$n <- paste('n =', totais$Freq)
totais$x <- 16
totais$y <- 18+1
totais[[variavel]] <- as.character(totais$Var1)
cna_disp_limpo[[variavel]] <- as.character(cna_disp_limpo[[variavel]])
ggplot(cna_disp_limpo, aes_string(y='idade_disponibilizacao', x=variavel)) +
geom_boxplot() +
geom_text(data=totais, aes_string(x=variavel, y='y', label='n'), colour="black")+
labs(x=label, y='Idade de Disponibilização') +
theme_bw()
}
p1 <- compara2('obito_dos_pais')
p2 <- compara2('descumprimento_injustificado_reiterado_dos_deveres_do_poder_familiar')
p3 <- compara2('ambiente_contrario_a_moral_e_bons_costumes')
p4 <- compara2('pais_desconhecidos')
p5 <- compara2('entrega_voluntaria')
p6 <- compara2('abandono')
source('multiplot.R')
multiplot(p1,p2,p3,p4,p5,p6, cols=2)
compara3 <- function(variavel, label=variavel) {
totais <- as.data.frame(table(cna_disp_limpo[[variavel]]))
totais$n <- paste(c('',''),'n = ', totais$Freq, sep='')
totais$x <- 16
totais$y <- .15
totais[[variavel]] <- as.character(totais$Var1)
cna_disp_limpo[[variavel]] <- as.character(cna_disp_limpo[[variavel]])
ggplot(cna_disp_limpo, aes_string(x='idade_disponibilizacao', fill=variavel)) +
geom_histogram(aes(y=..density..), binwidth=1, position='identity',alpha=.5) +
scale_x_continuous(breaks=0:18) +
labs(x='Idade de Disponibilização', y='Densidade', title=label, fill='') +
scale_fill_discrete(labels=paste(c('não (','sim ('),totais$n, ')', sep='')) +
theme_bw() +
theme(legend.position=c(.87,.77),
legend.background = element_rect(fill="transparent", size=.5, linetype="dotted"))
}
labels <- c('\nÓbito dos pais', 'Descumprimento injustificado \ndos deveres do poder familiar', 'Ambiente contrário a\n moral e os bons costumes', '\nPais desconhecidos', '\nEntrega voluntária','\nAbandono','\nCastigo Imoderado')
p1 <- compara3('obito_dos_pais', labels[1])
p2 <- compara3('descumprimento_injustificado_reiterado_dos_deveres_do_poder_familiar', labels[2])
p3 <- compara3('ambiente_contrario_a_moral_e_bons_costumes', labels[3])
p4 <- compara3('pais_desconhecidos', labels[4])
p5 <- compara3('entrega_voluntaria', labels[5])
p6 <- compara3('abandono', labels[6])
p7 <- compara3('castigo_imoderado', labels[7])
source('/home/CNJ/CNA/multiplot.R')
multiplot(p2,p3,p6,p1,p4,p5,p7, cols=2)
sum(floor(cna_disp_limpo$idade_disponibilizacao) %in% 7:10)/sum(floor(cna_disp_limpo$idade_disponibilizacao) %in% 0:18)
sum(floor(cna_disp_limpo$idade_disponibilizacao) %in% 0:2)/sum(floor(cna_disp_limpo$idade_disponibilizacao) %in% 0:18)
sum(floor(cna_disp_limpo$idade_disponibilizacao) %in% 3:6)/sum(floor(cna_disp_limpo$idade_disponibilizacao) %in% 0:18)
require(plyr)
tapply(cna_disp_limpo$idade_disponibilizacao, cna_disp_limpo$obito_dos_pais, median)
tapply(cna_disp_limpo$idade_disponibilizacao, cna_disp_limpo$descumprimento_injustificado_reiterado_dos_deveres_do_poder_familiar, median)
tapply(cna_disp_limpo$idade_disponibilizacao, cna_disp_limpo$ambiente_contrario_a_moral_e_bons_costumes, median)
tapply(cna_disp_limpo$idade_disponibilizacao, cna_disp_limpo$pais_desconhecidos, median)
tapply(cna_disp_limpo$idade_disponibilizacao, cna_disp_limpo$entrega_voluntaria, median)
tapply(cna_disp_limpo$idade_disponibilizacao, cna_disp_limpo$abandono, median)
teste <- function(x,y) {
t.test(x[y==0], x[y==1])
}
with(cna_disp_limpo, teste(idade_disponibilizacao, obito_dos_pais))
with(cna_disp_limpo, teste(idade_disponibilizacao, descumprimento_injustificado_reiterado_dos_deveres_do_poder_familiar))
with(cna_disp_limpo, teste(idade_disponibilizacao, ambiente_contrario_a_moral_e_bons_costumes))
with(cna_disp_limpo, teste(idade_disponibilizacao, entrega_voluntaria))
with(cna_disp_limpo, teste(idade_disponibilizacao, abandono))
Combinações
cna_disp_limpo$comb_motivos <- with(cna_disp_limpo, paste(obito_dos_pais,
descumprimento_injustificado_reiterado_dos_deveres_do_poder_familiar,
ambiente_contrario_a_moral_e_bons_costumes,
pais_desconhecidos,
entrega_voluntaria,
abandono, sep=''))
round(table(cna_disp_limpo$comb_motivos)/sum(table(cna_disp_limpo$comb_motivos))*100,2)
# Daqui eu concluo que as variáveis aparecem quase sempre sozinhas (70% das vezes)
Qual é o tempo de adoção após entrar no cadastro? Ainda não temos a informação da data da última atualização.
Entrega voluntária versus situacao da crianca
table(cna_disp_limpo$situacao_crianca, cna_disp_limpo$entrega_voluntaria)
var.categ.principal <- "entrega_voluntaria"
título.var.categ.principal <- "entrega_voluntaria"
var.categ.secundaria <- "situacao_crianca"
título.var.categ.secundaria <- "situacao_crianca"
tab <- table(cna_disp_limpo[,var.categ.secundaria], cna_disp_limpo[,var.categ.principal])
chisq.teste <- chisq.test(tab)$p.value
intercala(addmargins(tab,1),porcentagem_na_coluna(tab))
df <- as.data.frame(tab)
df$Tot <- rep(tapply(df$Freq, df$Var2, sum),each=length(levels(df$Var1)))
df$Prop <- with(df, Freq/Tot)
df$Lab <- with(df, paste(round(100*Prop,0),"%",sep=""))
df <- df[!is.nan(df$Prop),]
ggplot(df, aes(x = Var1, fill = Var1)) +
geom_bar(position = "dodge", aes(weights = Prop)) +
ylim(c(0,1)) +
geom_text(aes(y=Prop+.03, label=Lab), size = 5) +
labs(fill=título.var.categ.secundaria, title=título.var.categ.principal, x="", y = "Proporção", title="") +
facet_grid(. ~ Var2 , scales = "free_x") +
geom_text(aes(y=1, x=rep(ifelse(df[df$Var1==levels(df$Var1)[2],"Prop"]>0.75,1,2),each=length(levels(Var1))), label=paste("n =",Tot))) +
theme_bw() +
theme(axis.title.x=element_text(size=16),
axis.title.y=element_text(size=16),
axis.text.x=element_blank(),
axis.text.y=element_text(size=12),
axis.ticks=element_blank(),
legend.title=element_text(size=16),
legend.text=element_text(size=14),
legend.key.size = unit(1.5, "cm"),
strip.text.x = element_text(size=15))
Pedidos do Adilson
# Gostaria de propor uma conta;
#
# Vejam se agrega e se ajuda:
# Escolham duas categorias, digamos A e B.
# A categoria A poderia ser alguma faixa etária qualquer e a categoria B poderia ser não adotado. Divida a frequência relativa de A e B pelo produto das frequências relativas de A e de B. (Vamos chamar isto inicialmente de Lift).
#
# Se o Lift for 1 então independência.
# Se o Lift for maior que 1 então A induz B.
# Se o Lift for menor que 1 então A inibe B.
#
# Depois basta construir uma Matriz de As contra Bs ( a diagonal eh 1, claro) e partir para uma analise. Gostaria de ver...
# Ops, de fato a diagonal eh 1 na escala inversa da f(A). A diagonal dara o peso relativo da linha i e coluna j sobre o cadastro. Bom, se quiserem, conversamos + sobre isto depois. Abs
ggplot(cna_disp_limpo, aes(x=ano_disponibilizacao_num)) +
geom_histogram(aes(y=..density..), color='black', fill='white', binwidth=1) +
scale_x_continuous(breaks=1999:2013) +
theme_bw()
Tentativa do Julio: regressão logística para calcular probabilidade de adoção (estudo prospectivo!!!)
Problema: as crianças disponíveis ainda podem apresentar o evento "adoção"
unique(cna_disp_limpo$situacao_crianca2)
cna_disp_limpo_logistica <- cna_disp_limpo[cna_disp_limpo$situacao_crianca2 %in% c('Maioridade','Adotada'), ]
cna_disp_limpo_logistica$situacao_crianca2 <- as.character(cna_disp_limpo_logistica$situacao_crianca2)
cna_disp_limpo_logistica$Y <- ifelse(cna_disp_limpo_logistica$situacao_crianca2 %in% 'Adotada', 1,0)
fit.model <- glm(Y ~ sexo + regiao_estado_nascimento + tem_irmao + raca_cor + doenca_hiv + obito_dos_pais + entrega_voluntaria + idade_disponibilizacao, data=cna_disp_limpo_logistica, family=binomial)
summary(fit.model)
source('http://www.ime.usp.br/~giapaula/envel_bino')
Análise de sobrevivência para o tempo até a adoção
Kaplan meier para tempo até a adocao explicado por idade de disponibilidade
library(survival)
source("ggkm.R")
# indicador de idade de disponibilização maior que 5 anos
breaks <- c(0,5,Inf)
cna_disp_limpo$faixa_etaria_disponibilizacao <- cut(cna_disp_limpo$idade_disponibilizacao, breaks=breaks, include.lowest=T)
cna_disp_limpo$idade_disponibilizacao_5anosflag <- ifelse(cna_disp_limpo$idade_disponibilizacao > 5, 1, 0)
# tempo até evento, em dias
cna_disp_limpo$tempo_ate_evento <- with(cna_disp_limpo, as.numeric(data_ultima_alteracao - data_disponibilizacao_num)/24)
# flag para adocao
cna_disp_limpo$adotada <- ifelse(cna_disp_limpo$situacao_crianca2 %in% 'Adotada', 1,0)
# kaplan meier para tempo até a adocao explicado por idade de disponibilidade
ekm <- survfit(Surv(tempo_ate_evento, adotada) ~ faixa_etaria_disponibilizacao, data=cna_disp_limpo[cna_disp_limpo$situacao_crianca2%in%c("Adotada","Maioridade","Disponível"),])
a <-ggkm(sfit=ekm, returns=TRUE)
a + scale_x_continuous(breaks=seq(0,4800,200)) + labs(x="dias", y="Probabilidade de 'sobrevivência'")
Agora segregado por sexo.
A ideia é ver se meninas sofrem com a idade tanto quanto meninos.
# Meninas
ekm <- survfit(Surv(tempo_ate_evento, adotada) ~ idade_disponibilizacao_5anosflag, data=cna_disp_limpo[cna_disp_limpo$sexo%in%"F",])
ggkm_f <- ggkm(sfit=ekm, returns=TRUE, main="Feminino")
# Meninos
ekm <- survfit(Surv(tempo_ate_evento, adotada) ~ idade_disponibilizacao_5anosflag, data=cna_disp_limpo[cna_disp_limpo$sexo%in%"M",])
ggkm_m <- ggkm(sfit=ekm, returns=TRUE, main="Masculino")
multiplot(ggkm_f, ggkm_m, cols=2)
Invertendo a perspectiva. KMs dos sexos para cada faixa etária. Parece que sexo não faz diferença.
# < 5 anos
ekm <- survfit(Surv(tempo_ate_evento, adotada) ~ sexo, data=cna_disp_limpo[cna_disp_limpo$idade_disponibilizacao_5anosflag%in%0,])
ggkm_n <- ggkm(sfit=ekm, returns=TRUE, main="< 5 anos")
# > 5 anos
ekm <- survfit(Surv(tempo_ate_evento, adotada) ~ sexo, data=cna_disp_limpo[cna_disp_limpo$idade_disponibilizacao_5anosflag%in%1,])
ggkm_v <- ggkm(sfit=ekm, returns=TRUE, main="> 5 anos")
multiplot(ggkm_n, ggkm_v, cols=2)
Invertendo a perspectiva. KMs dos sexos para cada faixa etária. Parece que sexo não faz diferença.
# < 5 anos
ekm <- survfit(Surv(tempo_ate_evento, adotada) ~ sexo, data=cna_disp_limpo[cna_disp_limpo$idade_disponibilizacao_5anosflag%in%0,])
ggkm_n <- ggkm(sfit=ekm, returns=TRUE, main="< 5 anos")
# > 5 anos
ekm <- survfit(Surv(tempo_ate_evento, adotada) ~ sexo, data=cna_disp_limpo[cna_disp_limpo$idade_disponibilizacao_5anosflag%in%1,])
ggkm_v <- ggkm(sfit=ekm, returns=TRUE, main="> 5 anos")
multiplot(ggkm_n, ggkm_v, cols=2)
Idade pretendentes vs pretendidos
crianca_disponivel <- cna_disp[cna_disp$situacao_crianca %in% "Disponivel",]
pretendente_disponivel <- cna_pre[cna_pre$Situação.Pretendente %in% "Ativo",]
df <- data.frame(crianca = prop.table(table(crianca_disponivel$anos_completos)),
pretendente = -prop.table(table(pretendente_disponivel$idade_maxima)))
df2 <- melt(df)
cna_disp_limpo[[variavel]] <- as.character(cna_disp_limpo[[variavel]])
df2$crianca.Var1.num <- as.numeric(as.character(df2$crianca.Var1))
df2$pretendente.Var1.num <- as.numeric(as.character(df2$pretendente.Var1))
ggplot(df2, aes(x=pretendente.Var1, y=value, fill=variable)) +
geom_bar(data=df2[df2$variable%in%'crianca.Freq',], aes(x=crianca.Var1.num, y=value), alpha=.5, stat='identity',position='stack') +
geom_bar(data=df2[df2$variable%in%'pretendente.Freq',], aes(x=pretendente.Var1.num, y=value), alpha=.5, stat='identity') +
#scale_x_continuous(breaks=0:18) +
#labs(x='Idade', y='Densidade', fill='') +
#scale_fill_discrete(labels=paste(c('não (','sim ('),totais$n, ')', sep='')) +
theme_bw() +
ylim(c(-.2,.2)) +
scale_x_discrete(breaks=0:18,limits=0:18) +
theme(legend.position=c(.6,.3),
legend.background = element_rect(fill="transparent", size=.5, linetype="dotted"))
Qtd de entradas por intervalo de tempo
names(cna_disp_limpo)
require(dplyr)
cna_disp_limpo$anomes_disponibilizacao <- paste(year(cna_disp_limpo$data_disponibilizacao_num),
sprintf('%02d', month(cna_disp_limpo$data_disponibilizacao_num)))
table(cna_disp_limpo$anomes_disponibilizacao[cna_disp_limpo$ano_disponibilizacao_num >= 2008])
hist(table(cna_disp_limpo$anomes_disponibilizacao[cna_disp_limpo$ano_disponibilizacao_num >= 2008]))
ggplot(data.frame(table(cna_disp_limpo$anomes_disponibilizacao[cna_disp_limpo$ano_disponibilizacao_num >= 2008])),
aes(x=Var1, y=Freq, group=1)) + geom_point() + geom_line() + theme(axis.text.x=element_text(angle=45, hjust=1))
jtrecenti/adocao documentation built on May 20, 2019, 3:15 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Descritiva - CNA - Crianças Disponíveis
Banco de dados passado pelo CNJ no dia 05/09/2013.
require(ggplot2) require(stringr) require(plyr) require(reshape2) require(lubridate)
theme.st <- theme_bw() + theme(axis.title.x=element_text(size=16), axis.title.y=element_text(size=16), axis.text.x=element_text(size=16, hjust=0.5), axis.text.y=element_text(size=16), legend.title=element_text(size=16), legend.text=element_text(size=16), strip.text.x = element_text(angle=0, size=16), strip.text.y = element_text(angle=-90, size=16)) theme.boxplot.uni <- theme(axis.title.y=element_blank(), axis.title.x=element_text(size=16), axis.text.y=element_blank(), axis.text.x=element_text(size=16), axis.ticks.y=element_blank(), legend.title=element_text(size=16), legend.text=element_text(size=16)) theme.boxplot.bi <- theme(axis.title.x=element_blank(), axis.title.y=element_text(size=16), axis.text.x=element_text(size=12, angle=90, hjust=1, vjust=0.5), axis.text.y=element_text(size=16), axis.ticks.x=element_blank(), legend.title=element_text(size=16), legend.text=element_text(size=16))
# Carregando e limpando CSV cna_disp <- read.csv2('/home/CNJ/CNA/bd/cna_crianca_disp.csv', as.is=T) #names(cna_disp) cna_disp$data_disponibilizacao_num <- as.POSIXlt(cna_disp$DT.Disponibilização.Criança, format='%d/%m/%Y') cna_disp$ano_disponibilizacao_num <- cna_disp$data_disponibilizacao_num$year + 1900 cna_disp$data_nascimento_num <- as.POSIXlt(cna_disp$data_nascimento, format='%d/%m/%Y') #View(cna_disp[!is.na(cna_disp$ano_disponibilizacao_num) & cna_disp$ano_disponibilizacao_num < 1990,]) cna_disp$data_ultima_alteracao <- as.POSIXlt(cna_disp$Ult.Alteração, format='%d/%m/%Y %H:%M') cna_disp_limpo <- cna_disp[!is.na(cna_disp$ano_disponibilizacao_num) & cna_disp$ano_disponibilizacao_num >= 2000 & cna_disp$ano_disponibilizacao_num < 2014,] # # verifica se ano_disponibilizacao_num e Ano.Disp.Adoção são a mesma coisa # summary(with(cna_disp_limpo, ano_disponibilizacao_num - Ano.Disp.Adoção)) # table(is.na(cna_disp_limpo$ano_disponibilizacao_num),is.na(cna_disp_limpo$Ano.Disp.Adoção))
Retirada de r sum(is.na(cna_disp$data_disponibilizacao_num)) obs do BD por não ter informação da data de disponibilização.
Análise descritiva das crianças disponíveis
Com que idade as crianças ficaram disponíveis?
cna_disp_limpo$idade_disponibilizacao <- as.numeric(with(cna_disp_limpo, data_disponibilizacao_num - data_nascimento_num)/60/60/24/365) cna_disp_limpo <- cna_disp_limpo[cna_disp_limpo$idade_disponibilizacao >=0 & cna_disp_limpo$idade_disponibilizacao <=18,]
Graficos exploratorios
ggplot(cna_disp_limpo, aes(x=idade_disponibilizacao)) + geom_histogram(aes(y=..density..), color='black', fill='white')+ scale_x_continuous(breaks=0:18) + theme_bw() ggplot(cna_disp_limpo, aes(x=idade_disponibilizacao)) + geom_histogram(aes(y=..density.., fill=situacao_crianca))+ scale_x_continuous(breaks=0:18) + theme_bw() totais <- as.data.frame(table(cna_disp_limpo$situacao_crianca)) totais$n <- paste('n =', totais$Freq) totais$x <- 18 totais$y <- .5 ggplot(cna_disp_limpo, aes(x=idade_disponibilizacao, group=situacao_crianca)) + geom_histogram(aes(y=..density..), color='black', fill='white') + geom_text(data=totais, aes_string(x='x', y='y', label='n', group='Var1'), colour="black")+ facet_wrap(~situacao_crianca) + labs(x='Idade de Disponibilização', y='Densidade') + theme_bw() #quantile(cna_disp_limpo$idade_disponibilizacao[cna_disp_limpo$situacao_crianca %in% "Disponivel"],probs=c(0,0.15,1)) ggplot(cna_disp_limpo, aes(x=situacao_crianca, y=idade_disponibilizacao)) + geom_boxplot() + theme_bw() for(i in names(cna_disp_limpo)) { print(i) print(table(cna_disp_limpo[[i]])) }
Qual é o destino de crianças para cada faixa etária?
breaks <- c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,17,Inf) cna_disp_limpo$faixa_etaria_disponibilizacao <- cut(cna_disp_limpo$idade_disponibilizacao, breaks=breaks, include.lowest=T) levs <- levels(cna_disp_limpo$faixa_etaria_disponibilizacao) levels(cna_disp_limpo$faixa_etaria_disponibilizacao) <- c(levs[-length(levs)], '18 anos') cna_disp_limpo$situacao_crianca2 <- factor(cna_disp_limpo$situacao_crianca) levels(cna_disp_limpo$situacao_crianca2) <- c("Adotada", "Adotada", "Adotada", "Adoção em andamento", 'Maioridade', 'Disponível', 'Adoção em andamento', 'Faleceu', 'Consulta', 'Censura', 'Consulta','Censura') cna_disp_limpo$situacao_crianca3 <- factor(cna_disp_limpo$situacao_crianca) levels(cna_disp_limpo$situacao_crianca3) <- c("Adotada", "Adotada", "Adotada", "Outros", 'Maioridade', 'Disponível', 'Outros', 'Outros', 'Outros', 'Outros', 'Outros','Outros') tab <- with(cna_disp_limpo, table(situacao_crianca3,faixa_etaria_disponibilizacao)) tab_df <- merge(tab, prop.table(tab,2), by=c('situacao_crianca3', 'faixa_etaria_disponibilizacao')) tab_df <- merge(tab_df, data.frame(margin.table(tab,2)), by='faixa_etaria_disponibilizacao') tab_df$situacao_crianca3 <- as.character(tab_df$situacao_crianca3) ggplot(tab_df, aes(x=faixa_etaria_disponibilizacao, y=Freq.y*100, group=situacao_crianca3, colour=situacao_crianca3)) + geom_point() + geom_line() + geom_text(aes(x=faixa_etaria_disponibilizacao, y=80, label=Freq), color="black", alpha=.1, size=5) + labs(x='Idade de disponibilização (anos)', y='%', colour='Situação atual da criança') + theme.st
Analise dos 965 que atingiram maioridade
cna_disp_limpo_maior <- cna_disp_limpo[cna_disp_limpo$situacao_crianca %in% "Atingiu Maioridade",] cna_disp_limpo_nmaior <- cna_disp_limpo[!cna_disp_limpo$situacao_crianca %in% "Atingiu Maioridade",] tab_df <- data.frame(prop.table(table(cna_disp_limpo_maior$UF.abrigo))) tab_df2 <- data.frame(prop.table(table(cna_disp_limpo_nmaior$UF.abrigo))) tab_df_tot <- merge(tab_df2,tab_df,by='Var1', all.x=T) names(tab_df_tot) <- c('UF', 'prop_brasil', 'prop_maior') pchisq(sum((tab_df_tot$prop_maior-tab_df_tot$prop_brasil)^2/tab_df_tot$prop_brasil, na.rm=T),df=26,lower.tail=F) tab_df <- data.frame(prop.table(table(cna_disp_limpo_maior$faixa_etaria_disponibilizacao))) tab_df2 <- data.frame(prop.table(table(cna_disp_limpo_nmaior$faixa_etaria_disponibilizacao))) tab_df_tot <- merge(tab_df2,tab_df,by='Var1', all.x=T) names(tab_df_tot) <- c('UF', 'prop_brasil', 'prop_maior') pchisq(sum((tab_df_tot$prop_maior-tab_df_tot$prop_brasil)^2/tab_df_tot$prop_brasil, na.rm=T),df=nrow(tab_df_tot)-1,lower.tail=F) teste <- function(var) { tab_df <- data.frame(table(cna_disp_limpo_maior[[var]])) tab_df2 <- data.frame(prop.table(table(cna_disp_limpo_nmaior[[var]]))*(sum(tab_df$Freq))) tab_df_tot <- merge(tab_df2,tab_df,by='Var1', all.x=T) names(tab_df_tot) <- c(var, 'prop_brasil', 'prop_maior') chisquare <- sum((tab_df_tot$prop_maior-tab_df_tot$prop_brasil)^2/tab_df_tot$prop_brasil, na.rm=T) vp <- pchisq(chisquare,df=nrow(tab_df_tot)-1,lower.tail=F) return(list(tab_df_tot, vp)) } (df_testes <- lapply(names(cna_disp_limpo)[c(7:13,15:33,38)],teste)) df_testes[sapply(df_testes, function(x) x[[2]] < 1e-10)] addmargins(round(prop.table(table(cna_disp_limpo$faixa_etaria_disponibilizacao, cna_disp_limpo$entrega_voluntaria),2)*100,2),1) addmargins(round(prop.table(table(cna_disp_limpo$faixa_etaria_disponibilizacao, cna_disp_limpo$obito_dos_pais),2)*100,2),1)
Idade de disponibilizacao vs origem
compara <- function(variavel, label=variavel) { totais <- as.data.frame(table(cna_disp_limpo[[variavel]])) totais$n <- paste('n =', totais$Freq) totais$x <- 16 totais$y <- .15 totais[[variavel]] <- as.character(totais$Var1) cna_disp_limpo[[variavel]] <- as.character(cna_disp_limpo[[variavel]]) ggplot(cna_disp_limpo, aes_string(x='idade_disponibilizacao', group=variavel)) + geom_histogram(aes(y=..density..), color='black', fill='white', binwidth=1) + facet_wrap(as.formula(paste('~',variavel))) + geom_text(data=totais, aes_string(x='x', y='y', label='n', group=variavel), colour="black")+ scale_x_continuous(breaks=0:18) + labs(x='Idade de Disponibilização', y='Densidade', title=label) + theme_bw() } totais <- as.data.frame(table(cna_disp_limpo$situacao_crianca)) totais$n <- paste('n =', totais$Freq) totais$x <- 16 totais$y <- .5 totais$situacao_crianca <- totais$Var1 ggplot(cna_disp_limpo, aes(x=idade_disponibilizacao, group=situacao_crianca)) + geom_histogram(aes(y=..density..), color='black', fill='royalblue', binwidth=1, alpha=.8) + facet_wrap(~situacao_crianca) + geom_text(data=totais, aes_string(x='x', y='y', label='n', group='situacao_crianca'), colour="black")+ scale_x_continuous(breaks=seq(0,18,by=2)) + labs(x='Idade de Disponibilização', y='Densidade') + theme_bw() + theme(strip.text.x=element_text(size=12), axis.text=element_text(size=11), axis.title=element_text(size=14)) total <- data.frame(nrow(cna_disp_limpo), n=paste('n =',nrow(cna_disp_limpo)), x=15, y=0.14) ggplot(cna_disp_limpo, aes(x=idade_disponibilizacao)) + geom_histogram(aes(y=..density..), color='black', fill='lightblue', binwidth=.5, alpha=.1) + geom_text(data=total, aes_string(x='x', y='y', label='n'), colour="black")+ scale_x_continuous(breaks=seq(0,18,by=1)) + labs(x='Idade de Disponibilização', y='Densidade') + theme_bw() + theme(strip.text.x=element_text(size=12), axis.text=element_text(size=11), axis.title=element_text(size=14)) p1 <- compara('obito_dos_pais') p2 <- compara('descumprimento_injustificado_reiterado_dos_deveres_do_poder_familiar') p3 <- compara('ambiente_contrario_a_moral_e_bons_costumes') p4 <- compara('pais_desconhecidos') p5 <- compara('entrega_voluntaria') p6 <- compara('abandono') source('multiplot.R') multiplot(p1,p2,p3,p4,p5,p6, cols=2)
compara2 <- function(variavel, label=variavel) { totais <- as.data.frame(table(cna_disp_limpo[[variavel]])) totais$n <- paste('n =', totais$Freq) totais$x <- 16 totais$y <- 18+1 totais[[variavel]] <- as.character(totais$Var1) cna_disp_limpo[[variavel]] <- as.character(cna_disp_limpo[[variavel]]) ggplot(cna_disp_limpo, aes_string(y='idade_disponibilizacao', x=variavel)) + geom_boxplot() + geom_text(data=totais, aes_string(x=variavel, y='y', label='n'), colour="black")+ labs(x=label, y='Idade de Disponibilização') + theme_bw() } p1 <- compara2('obito_dos_pais') p2 <- compara2('descumprimento_injustificado_reiterado_dos_deveres_do_poder_familiar') p3 <- compara2('ambiente_contrario_a_moral_e_bons_costumes') p4 <- compara2('pais_desconhecidos') p5 <- compara2('entrega_voluntaria') p6 <- compara2('abandono') source('multiplot.R') multiplot(p1,p2,p3,p4,p5,p6, cols=2)
compara3 <- function(variavel, label=variavel) { totais <- as.data.frame(table(cna_disp_limpo[[variavel]])) totais$n <- paste(c('',''),'n = ', totais$Freq, sep='') totais$x <- 16 totais$y <- .15 totais[[variavel]] <- as.character(totais$Var1) cna_disp_limpo[[variavel]] <- as.character(cna_disp_limpo[[variavel]]) ggplot(cna_disp_limpo, aes_string(x='idade_disponibilizacao', fill=variavel)) + geom_histogram(aes(y=..density..), binwidth=1, position='identity',alpha=.5) + scale_x_continuous(breaks=0:18) + labs(x='Idade de Disponibilização', y='Densidade', title=label, fill='') + scale_fill_discrete(labels=paste(c('não (','sim ('),totais$n, ')', sep='')) + theme_bw() + theme(legend.position=c(.87,.77), legend.background = element_rect(fill="transparent", size=.5, linetype="dotted")) } labels <- c('\nÓbito dos pais', 'Descumprimento injustificado \ndos deveres do poder familiar', 'Ambiente contrário a\n moral e os bons costumes', '\nPais desconhecidos', '\nEntrega voluntária','\nAbandono','\nCastigo Imoderado') p1 <- compara3('obito_dos_pais', labels[1]) p2 <- compara3('descumprimento_injustificado_reiterado_dos_deveres_do_poder_familiar', labels[2]) p3 <- compara3('ambiente_contrario_a_moral_e_bons_costumes', labels[3]) p4 <- compara3('pais_desconhecidos', labels[4]) p5 <- compara3('entrega_voluntaria', labels[5]) p6 <- compara3('abandono', labels[6]) p7 <- compara3('castigo_imoderado', labels[7]) source('/home/CNJ/CNA/multiplot.R') multiplot(p2,p3,p6,p1,p4,p5,p7, cols=2) sum(floor(cna_disp_limpo$idade_disponibilizacao) %in% 7:10)/sum(floor(cna_disp_limpo$idade_disponibilizacao) %in% 0:18) sum(floor(cna_disp_limpo$idade_disponibilizacao) %in% 0:2)/sum(floor(cna_disp_limpo$idade_disponibilizacao) %in% 0:18) sum(floor(cna_disp_limpo$idade_disponibilizacao) %in% 3:6)/sum(floor(cna_disp_limpo$idade_disponibilizacao) %in% 0:18)
require(plyr) tapply(cna_disp_limpo$idade_disponibilizacao, cna_disp_limpo$obito_dos_pais, median) tapply(cna_disp_limpo$idade_disponibilizacao, cna_disp_limpo$descumprimento_injustificado_reiterado_dos_deveres_do_poder_familiar, median) tapply(cna_disp_limpo$idade_disponibilizacao, cna_disp_limpo$ambiente_contrario_a_moral_e_bons_costumes, median) tapply(cna_disp_limpo$idade_disponibilizacao, cna_disp_limpo$pais_desconhecidos, median) tapply(cna_disp_limpo$idade_disponibilizacao, cna_disp_limpo$entrega_voluntaria, median) tapply(cna_disp_limpo$idade_disponibilizacao, cna_disp_limpo$abandono, median) teste <- function(x,y) { t.test(x[y==0], x[y==1]) } with(cna_disp_limpo, teste(idade_disponibilizacao, obito_dos_pais)) with(cna_disp_limpo, teste(idade_disponibilizacao, descumprimento_injustificado_reiterado_dos_deveres_do_poder_familiar)) with(cna_disp_limpo, teste(idade_disponibilizacao, ambiente_contrario_a_moral_e_bons_costumes)) with(cna_disp_limpo, teste(idade_disponibilizacao, entrega_voluntaria)) with(cna_disp_limpo, teste(idade_disponibilizacao, abandono))
Combinações
cna_disp_limpo$comb_motivos <- with(cna_disp_limpo, paste(obito_dos_pais, descumprimento_injustificado_reiterado_dos_deveres_do_poder_familiar, ambiente_contrario_a_moral_e_bons_costumes, pais_desconhecidos, entrega_voluntaria, abandono, sep='')) round(table(cna_disp_limpo$comb_motivos)/sum(table(cna_disp_limpo$comb_motivos))*100,2) # Daqui eu concluo que as variáveis aparecem quase sempre sozinhas (70% das vezes)
Qual é o tempo de adoção após entrar no cadastro? Ainda não temos a informação da data da última atualização.
Entrega voluntária versus situacao da crianca
table(cna_disp_limpo$situacao_crianca, cna_disp_limpo$entrega_voluntaria) var.categ.principal <- "entrega_voluntaria" título.var.categ.principal <- "entrega_voluntaria" var.categ.secundaria <- "situacao_crianca" título.var.categ.secundaria <- "situacao_crianca" tab <- table(cna_disp_limpo[,var.categ.secundaria], cna_disp_limpo[,var.categ.principal]) chisq.teste <- chisq.test(tab)$p.value intercala(addmargins(tab,1),porcentagem_na_coluna(tab)) df <- as.data.frame(tab) df$Tot <- rep(tapply(df$Freq, df$Var2, sum),each=length(levels(df$Var1))) df$Prop <- with(df, Freq/Tot) df$Lab <- with(df, paste(round(100*Prop,0),"%",sep="")) df <- df[!is.nan(df$Prop),] ggplot(df, aes(x = Var1, fill = Var1)) + geom_bar(position = "dodge", aes(weights = Prop)) + ylim(c(0,1)) + geom_text(aes(y=Prop+.03, label=Lab), size = 5) + labs(fill=título.var.categ.secundaria, title=título.var.categ.principal, x="", y = "Proporção", title="") + facet_grid(. ~ Var2 , scales = "free_x") + geom_text(aes(y=1, x=rep(ifelse(df[df$Var1==levels(df$Var1)[2],"Prop"]>0.75,1,2),each=length(levels(Var1))), label=paste("n =",Tot))) + theme_bw() + theme(axis.title.x=element_text(size=16), axis.title.y=element_text(size=16), axis.text.x=element_blank(), axis.text.y=element_text(size=12), axis.ticks=element_blank(), legend.title=element_text(size=16), legend.text=element_text(size=14), legend.key.size = unit(1.5, "cm"), strip.text.x = element_text(size=15))
Pedidos do Adilson
# Gostaria de propor uma conta; # # Vejam se agrega e se ajuda: # Escolham duas categorias, digamos A e B. # A categoria A poderia ser alguma faixa etária qualquer e a categoria B poderia ser não adotado. Divida a frequência relativa de A e B pelo produto das frequências relativas de A e de B. (Vamos chamar isto inicialmente de Lift). # # Se o Lift for 1 então independência. # Se o Lift for maior que 1 então A induz B. # Se o Lift for menor que 1 então A inibe B. # # Depois basta construir uma Matriz de As contra Bs ( a diagonal eh 1, claro) e partir para uma analise. Gostaria de ver... # Ops, de fato a diagonal eh 1 na escala inversa da f(A). A diagonal dara o peso relativo da linha i e coluna j sobre o cadastro. Bom, se quiserem, conversamos + sobre isto depois. Abs ggplot(cna_disp_limpo, aes(x=ano_disponibilizacao_num)) + geom_histogram(aes(y=..density..), color='black', fill='white', binwidth=1) + scale_x_continuous(breaks=1999:2013) + theme_bw()
Tentativa do Julio: regressão logística para calcular probabilidade de adoção (estudo prospectivo!!!) Problema: as crianças disponíveis ainda podem apresentar o evento "adoção"
unique(cna_disp_limpo$situacao_crianca2) cna_disp_limpo_logistica <- cna_disp_limpo[cna_disp_limpo$situacao_crianca2 %in% c('Maioridade','Adotada'), ] cna_disp_limpo_logistica$situacao_crianca2 <- as.character(cna_disp_limpo_logistica$situacao_crianca2) cna_disp_limpo_logistica$Y <- ifelse(cna_disp_limpo_logistica$situacao_crianca2 %in% 'Adotada', 1,0) fit.model <- glm(Y ~ sexo + regiao_estado_nascimento + tem_irmao + raca_cor + doenca_hiv + obito_dos_pais + entrega_voluntaria + idade_disponibilizacao, data=cna_disp_limpo_logistica, family=binomial) summary(fit.model) source('http://www.ime.usp.br/~giapaula/envel_bino')
Análise de sobrevivência para o tempo até a adoção
Kaplan meier para tempo até a adocao explicado por idade de disponibilidade
library(survival) source("ggkm.R") # indicador de idade de disponibilização maior que 5 anos breaks <- c(0,5,Inf) cna_disp_limpo$faixa_etaria_disponibilizacao <- cut(cna_disp_limpo$idade_disponibilizacao, breaks=breaks, include.lowest=T) cna_disp_limpo$idade_disponibilizacao_5anosflag <- ifelse(cna_disp_limpo$idade_disponibilizacao > 5, 1, 0) # tempo até evento, em dias cna_disp_limpo$tempo_ate_evento <- with(cna_disp_limpo, as.numeric(data_ultima_alteracao - data_disponibilizacao_num)/24) # flag para adocao cna_disp_limpo$adotada <- ifelse(cna_disp_limpo$situacao_crianca2 %in% 'Adotada', 1,0) # kaplan meier para tempo até a adocao explicado por idade de disponibilidade ekm <- survfit(Surv(tempo_ate_evento, adotada) ~ faixa_etaria_disponibilizacao, data=cna_disp_limpo[cna_disp_limpo$situacao_crianca2%in%c("Adotada","Maioridade","Disponível"),]) a <-ggkm(sfit=ekm, returns=TRUE) a + scale_x_continuous(breaks=seq(0,4800,200)) + labs(x="dias", y="Probabilidade de 'sobrevivência'")
Agora segregado por sexo.
A ideia é ver se meninas sofrem com a idade tanto quanto meninos.
# Meninas ekm <- survfit(Surv(tempo_ate_evento, adotada) ~ idade_disponibilizacao_5anosflag, data=cna_disp_limpo[cna_disp_limpo$sexo%in%"F",]) ggkm_f <- ggkm(sfit=ekm, returns=TRUE, main="Feminino") # Meninos ekm <- survfit(Surv(tempo_ate_evento, adotada) ~ idade_disponibilizacao_5anosflag, data=cna_disp_limpo[cna_disp_limpo$sexo%in%"M",]) ggkm_m <- ggkm(sfit=ekm, returns=TRUE, main="Masculino") multiplot(ggkm_f, ggkm_m, cols=2)
Invertendo a perspectiva. KMs dos sexos para cada faixa etária. Parece que sexo não faz diferença.
# < 5 anos ekm <- survfit(Surv(tempo_ate_evento, adotada) ~ sexo, data=cna_disp_limpo[cna_disp_limpo$idade_disponibilizacao_5anosflag%in%0,]) ggkm_n <- ggkm(sfit=ekm, returns=TRUE, main="< 5 anos") # > 5 anos ekm <- survfit(Surv(tempo_ate_evento, adotada) ~ sexo, data=cna_disp_limpo[cna_disp_limpo$idade_disponibilizacao_5anosflag%in%1,]) ggkm_v <- ggkm(sfit=ekm, returns=TRUE, main="> 5 anos") multiplot(ggkm_n, ggkm_v, cols=2)
Invertendo a perspectiva. KMs dos sexos para cada faixa etária. Parece que sexo não faz diferença.
# < 5 anos ekm <- survfit(Surv(tempo_ate_evento, adotada) ~ sexo, data=cna_disp_limpo[cna_disp_limpo$idade_disponibilizacao_5anosflag%in%0,]) ggkm_n <- ggkm(sfit=ekm, returns=TRUE, main="< 5 anos") # > 5 anos ekm <- survfit(Surv(tempo_ate_evento, adotada) ~ sexo, data=cna_disp_limpo[cna_disp_limpo$idade_disponibilizacao_5anosflag%in%1,]) ggkm_v <- ggkm(sfit=ekm, returns=TRUE, main="> 5 anos") multiplot(ggkm_n, ggkm_v, cols=2)
Idade pretendentes vs pretendidos
crianca_disponivel <- cna_disp[cna_disp$situacao_crianca %in% "Disponivel",] pretendente_disponivel <- cna_pre[cna_pre$Situação.Pretendente %in% "Ativo",] df <- data.frame(crianca = prop.table(table(crianca_disponivel$anos_completos)), pretendente = -prop.table(table(pretendente_disponivel$idade_maxima))) df2 <- melt(df) cna_disp_limpo[[variavel]] <- as.character(cna_disp_limpo[[variavel]]) df2$crianca.Var1.num <- as.numeric(as.character(df2$crianca.Var1)) df2$pretendente.Var1.num <- as.numeric(as.character(df2$pretendente.Var1)) ggplot(df2, aes(x=pretendente.Var1, y=value, fill=variable)) + geom_bar(data=df2[df2$variable%in%'crianca.Freq',], aes(x=crianca.Var1.num, y=value), alpha=.5, stat='identity',position='stack') + geom_bar(data=df2[df2$variable%in%'pretendente.Freq',], aes(x=pretendente.Var1.num, y=value), alpha=.5, stat='identity') + #scale_x_continuous(breaks=0:18) + #labs(x='Idade', y='Densidade', fill='') + #scale_fill_discrete(labels=paste(c('não (','sim ('),totais$n, ')', sep='')) + theme_bw() + ylim(c(-.2,.2)) + scale_x_discrete(breaks=0:18,limits=0:18) + theme(legend.position=c(.6,.3), legend.background = element_rect(fill="transparent", size=.5, linetype="dotted"))
Qtd de entradas por intervalo de tempo
names(cna_disp_limpo) require(dplyr) cna_disp_limpo$anomes_disponibilizacao <- paste(year(cna_disp_limpo$data_disponibilizacao_num), sprintf('%02d', month(cna_disp_limpo$data_disponibilizacao_num))) table(cna_disp_limpo$anomes_disponibilizacao[cna_disp_limpo$ano_disponibilizacao_num >= 2008]) hist(table(cna_disp_limpo$anomes_disponibilizacao[cna_disp_limpo$ano_disponibilizacao_num >= 2008])) ggplot(data.frame(table(cna_disp_limpo$anomes_disponibilizacao[cna_disp_limpo$ano_disponibilizacao_num >= 2008])), aes(x=Var1, y=Freq, group=1)) + geom_point() + geom_line() + theme(axis.text.x=element_text(angle=45, hjust=1))
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.