Prova técnica Red-Exercicio1
Italo Iveldo
19/01/2021
Prova técnica
Bibliotecas
library(dplyr)##
## Attaching package: 'dplyr'## The following objects are masked from 'package:stats':
##
## filter, lag## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, unionlibrary(visdat)
#install.packages("lubridate")
library(lubridate)##
## Attaching package: 'lubridate'## The following objects are masked from 'package:base':
##
## date, intersect, setdiff, unionlibrary(ggplot2)
library(corrplot)## corrplot 0.84 loaded#install.packages("forecast")
library(forecast)## Registered S3 method overwritten by 'quantmod':
## method from
## as.zoo.data.frame zoolibrary(plotly)##
## Attaching package: 'plotly'## The following object is masked from 'package:ggplot2':
##
## last_plot## The following object is masked from 'package:stats':
##
## filter## The following object is masked from 'package:graphics':
##
## layout#install.packages("echarts4r")
library("echarts4r")
#install.packages("tidyverse")
library(tidyverse)## -- Attaching packages --------------------------------------- tidyverse 1.3.0 --## v tibble 3.0.1 v purrr 0.3.4
## v tidyr 1.1.2 v stringr 1.4.0
## v readr 1.4.0 v forcats 0.5.0## -- Conflicts ------------------------------------------ tidyverse_conflicts() --
## x lubridate::as.difftime() masks base::as.difftime()
## x lubridate::date() masks base::date()
## x plotly::filter() masks dplyr::filter(), stats::filter()
## x lubridate::intersect() masks base::intersect()
## x dplyr::lag() masks stats::lag()
## x lubridate::setdiff() masks base::setdiff()
## x lubridate::union() masks base::union()library(caret)## Loading required package: lattice##
## Attaching package: 'caret'## The following object is masked from 'package:purrr':
##
## lift#install.packages("factoextra")
library(factoextra)## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBa#install.packages("ROSE")
library(ROSE)## Loaded ROSE 0.0-3library(randomForest)## randomForest 4.6-14## Type rfNews() to see new features/changes/bug fixes.##
## Attaching package: 'randomForest'## The following object is masked from 'package:ggplot2':
##
## margin## The following object is masked from 'package:dplyr':
##
## combineExercicio 1- Análise descritiva
setwd("C:/Users/italo/OneDrive/Redsset")
df <- read.csv2("BASE_TITULOS.txt",sep="\t", header=TRUE)
head(df)## CODIGO NOME_FUNDO TIPO_PRODUTO CEDENTE SACADO LIMITE_CEDENTE
## 1 1 Fundo 1 Produto 1 Cedente 2 Sacado 249 10000000
## 2 2 Fundo 2 Produto 1 Cedente 1 Sacado 1372 8035714
## 3 3 Fundo 1 Produto 1 Cedente 2 Sacado 346 10000000
## 4 4 Fundo 2 Produto 1 Cedente 1 Sacado 585 8035714
## 5 5 Fundo 1 Produto 1 Cedente 2 Sacado 2184 10000000
## 6 6 Fundo 2 Produto 1 Cedente 1 Sacado 589 8035714
## ESTADO_CEDENTE ESTADO_SACADO VENCIMENTO DATA_EMISSAO DATA_PAGAMENTO
## 1 CE SP 2018-03-18 2017-10-28 2018-03-18
## 2 PA MG 2018-06-24 2018-05-21 2018-06-21
## 3 CE PR 2018-03-19 2017-11-29 2018-03-21
## 4 PA PA 2018-04-03 2018-02-14 2018-04-06
## 5 CE RJ 2018-02-02 2017-11-03 2018-02-02
## 6 PA SC 2018-05-14 2018-03-06 2018-05-14
## VALOR_REAL VALOR_DESAGIO TAXA_MENSAL RISCO_1 RISCO_2 RISCO_3 RISCO_4
## 1 1190.99 166.3848694 0.028213586 0.028472 1 0
## 2 29209.38 571.781205 0.017252543 0.192935 0.5 0.958204 0.014139
## 3 756.66 63.95158064 0.022374607 0.033609 1 0
## 4 7869.88 190.7647277 0.015081806 0.183401 0.5 0.124609 0.007712
## 5 1064.92 105.9766933 0.031770113 0.028472 1 0
## 6 7383.22 351.7446532 0.020441362 1 0.9 0.073837 0.011568
## RISCO_5 RISCO_6 RISCO_7 RISCO_8 RISCO_9 RISCO_10 RISCO_11 RISCO_12
## 1 0 0 0.610895141 0 0
## 2 0.013354 0.246686 0 0.380524644 0.020198 0.015453 0.666667 0.161228
## 3 0 0 0.58137927 0 0
## 4 0.000024 0.684831 0 0.179036362 0.020187 0.128587 0.666667 0.099808
## 5 0 0 0.514459388 0 0
## 6 0.013354 0.179676 0 0.304978593 0.000266 0.131347 0.333333 0.101727
## RISCO_13 RISCO_14 RISCO_15 RISCO_16 RISCO_17 RISCO_18 RISCO_19 RISCO_20
## 1 0.168124 0 0.066667 0.2 0.727965 0.738669 0.407407 0.860111
## 2 0.392065 0 0.266667 0.6 0.010041 0.012547 0.395062 0.698438
## 3 0.109617 0 0.066667 0.2 0.327489 0.321123 0.395062 0.890059
## 4 0.415602 0 0.4 0.6 0.012217 0.017485 0.419753 0.609827
## 5 0.168124 0 0.066667 0.2 0.727965 0.738669 0.407407 0.860111
## 6 0.415602 0 0.2 0.6 0.022618 0.032021 0.419753 0.616463
## RISCO_21 STATUS_LIQ_TITULO
## 1 0.985155 EM_DIA
## 2 0.707374 EM_DIA
## 3 0.98756 ATRASO
## 4 0.906279 ATRASO
## 5 0.368493 EM_DIA
## 6 0.009666 EM_DIAMetadados
Usei a função glimpse para visualizar melhor como as features estão definidas, de cara já da para ver que temos variáveis especificadas de forma errada.
glimpse(df)## Rows: 9,415
## Columns: 36
## $ CODIGO <int> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15...
## $ NOME_FUNDO <chr> "Fundo 1", "Fundo 2", "Fundo 1", "Fundo 2", "Fund...
## $ TIPO_PRODUTO <chr> "Produto 1", "Produto 1", "Produto 1", "Produto 1...
## $ CEDENTE <chr> "Cedente 2", "Cedente 1", "Cedente 2", "Cedente 1...
## $ SACADO <chr> "Sacado 249", "Sacado 1372", "Sacado 346", "Sacad...
## $ LIMITE_CEDENTE <int> 10000000, 8035714, 10000000, 8035714, 10000000, 8...
## $ ESTADO_CEDENTE <chr> "CE", "PA", "CE", "PA", "CE", "PA", "PA", "PA", "...
## $ ESTADO_SACADO <chr> "SP", "MG", "PR", "PA", "RJ", "SC", "SP", "PA", "...
## $ VENCIMENTO <chr> "2018-03-18", "2018-06-24", "2018-03-19", "2018-0...
## $ DATA_EMISSAO <chr> "2017-10-28", "2018-05-21", "2017-11-29", "2018-0...
## $ DATA_PAGAMENTO <chr> "2018-03-18", "2018-06-21", "2018-03-21", "2018-0...
## $ VALOR_REAL <chr> "1190.99", "29209.38", "756.66", "7869.88", "1064...
## $ VALOR_DESAGIO <chr> "166.3848694", "571.781205", "63.95158064", "190....
## $ TAXA_MENSAL <chr> "0.028213586", "0.017252543", "0.022374607", "0.0...
## $ RISCO_1 <chr> "0.028472", "0.192935", "0.033609", "0.183401", "...
## $ RISCO_2 <chr> "1", "0.5", "1", "0.5", "1", "0.9", "0.9", "0.5",...
## $ RISCO_3 <chr> "0", "0.958204", "0", "0.124609", "0", "0.073837"...
## $ RISCO_4 <chr> "", "0.014139", "", "0.007712", "", "0.011568", "...
## $ RISCO_5 <chr> "0", "0.013354", "0", "0.000024", "0", "0.013354"...
## $ RISCO_6 <chr> "", "0.246686", "", "0.684831", "", "0.179676", "...
## $ RISCO_7 <chr> "0", "0", "0", "0", "0", "0", "0", "0", "0", "0",...
## $ RISCO_8 <chr> "0.610895141", "0.380524644", "0.58137927", "0.17...
## $ RISCO_9 <chr> "0", "0.020198", "0", "0.020187", "0", "0.000266"...
## $ RISCO_10 <chr> "", "0.015453", "", "0.128587", "", "0.131347", "...
## $ RISCO_11 <chr> "0", "0.666667", "0", "0.666667", "0", "0.333333"...
## $ RISCO_12 <chr> "", "0.161228", "", "0.099808", "", "0.101727", "...
## $ RISCO_13 <chr> "0.168124", "0.392065", "0.109617", "0.415602", "...
## $ RISCO_14 <int> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0...
## $ RISCO_15 <chr> "0.066667", "0.266667", "0.066667", "0.4", "0.066...
## $ RISCO_16 <chr> "0.2", "0.6", "0.2", "0.6", "0.2", "0.6", "0.8", ...
## $ RISCO_17 <chr> "0.727965", "0.010041", "0.327489", "0.012217", "...
## $ RISCO_18 <chr> "0.738669", "0.012547", "0.321123", "0.017485", "...
## $ RISCO_19 <chr> "0.407407", "0.395062", "0.395062", "0.419753", "...
## $ RISCO_20 <chr> "0.860111", "0.698438", "0.890059", "0.609827", "...
## $ RISCO_21 <chr> "0.985155", "0.707374", "0.98756", "0.906279", "0...
## $ STATUS_LIQ_TITULO <chr> "EM_DIA", "EM_DIA", "ATRASO", "ATRASO", "EM_DIA",...Tratando dados
Analisando se as variáveis estão no formato correto
Antes de qualquer análise decidir validar as variáveis do dataset e formata-las do jeito correto.
A maioria das variáveis estão formatadas como texto, analisando os dados decidir fazer as seguintes alterações:
df$LIMITE_CEDENTE = as.numeric(df$LIMITE_CEDENTE)
df$VALOR_REAL= as.numeric(df$VALOR_REAL)
df$VALOR_DESAGIO= as.numeric(df$VALOR_DESAGIO)
df$TAXA_MENSAL= as.numeric(df$TAXA_MENSAL)
df[,15:35] = sapply(df[,15:35], as.numeric)
df$DATA_EMISSAO= ymd(df$DATA_EMISSAO)
df$DATA_PAGAMENTO=ymd(df$DATA_PAGAMENTO)
df$VENCIMENTO= ymd(df$VENCIMENTO)
df$ANO= year(df$DATA_PAGAMENTO)
df$ANO= as.factor(df$ANO)
df$NOME_FUNDO= as.factor(df$NOME_FUNDO)
df$ESTADO_CEDENTE=as.factor(df$ESTADO_CEDENTE)
df$ESTADO_SACADO= as.factor(df$ESTADO_SACADO)
df$TIPO_PRODUTO= as.factor(df$TIPO_PRODUTO)
df$STATUS_LIQ_TITULO= as.factor(df$STATUS_LIQ_TITULO)
df$SACADO= as.factor(df$SACADO)
df$CEDENTE= as.factor(df$CEDENTE)
vis_dat(df)
A visualização acima mostrou outro problema que são os valores NA’s, a grande maioria estão nas variáveis de Risco.
Avaliando os dados NA’s
Os dados abaixo mostram as porcentagens dos valores NA’s em cada coluna do dataset.
#Numero de valores faltantes em porcentagem
colSums(is.na(df))/length(df$CODIGO)*100## CODIGO NOME_FUNDO TIPO_PRODUTO CEDENTE
## 0.0000000 0.0000000 0.0000000 0.0000000
## SACADO LIMITE_CEDENTE ESTADO_CEDENTE ESTADO_SACADO
## 0.0000000 0.0000000 0.0000000 0.0000000
## VENCIMENTO DATA_EMISSAO DATA_PAGAMENTO VALOR_REAL
## 0.0000000 0.0000000 0.0000000 0.0000000
## VALOR_DESAGIO TAXA_MENSAL RISCO_1 RISCO_2
## 0.0000000 0.0212427 0.0000000 0.0000000
## RISCO_3 RISCO_4 RISCO_5 RISCO_6
## 0.0000000 72.7243760 0.0000000 82.3579395
## RISCO_7 RISCO_8 RISCO_9 RISCO_10
## 0.0000000 0.0000000 0.0000000 47.6367499
## RISCO_11 RISCO_12 RISCO_13 RISCO_14
## 0.0000000 82.4641529 0.4248540 0.0000000
## RISCO_15 RISCO_16 RISCO_17 RISCO_18
## 0.0000000 0.0000000 0.0000000 0.0000000
## RISCO_19 RISCO_20 RISCO_21 STATUS_LIQ_TITULO
## 1.4551248 0.0000000 0.0000000 0.0000000
## ANO
## 0.0000000As colunas RISCO_10, RISCO_6,RISCO_12,RISCO_4 possui muitos valores ausentes. O melhor tratamento que julguei efetivo foi a remoção dessas colunas.
df$RISCO_10=NULL
df$RISCO_6= NULL
df$RISCO_12=NULL
df$RISCO_4= NULLComo as colunas RISCOS_XX não serão utilizadas no momento deixarei as outras colunas para fazer um tratamento depois. Existe uma quantidade baixa de valores faltantes na coluna TAXA_MENSAL, por conta disso optei por apenas retirar essas linhas do dataset.
df <- df[!is.na(df$TAXA_MENSAL),]Outlines
É difícil saber o que corresponde a outlines ou não, se fizer uma análise por fundo terei um valor, se fizer por UF terei outro. A relação que ao meu entender parece trazer com mais clareza os outlines é o valor real por produtos oferecidos.
length(boxplot(df$VALOR_REAL~df$TIPO_PRODUTO,main="Número de outlines do DESAGIO por tipo de produto")$out)
## [1] 1147O boxplot indicou 1147 outlines, escolhi não fazer nenhum tratamento pois o problema parece ser complexo demais para julgar os outlines apenas em uma relação com duas variáveis.
Analises Exploratória
A principio analisei um panoráma geral de cada coluna para entender como os dados estão distribuídos.
summary(df)## CODIGO NOME_FUNDO TIPO_PRODUTO CEDENTE
## Min. : 1 Fundo 1:6005 Produto 1:7865 Cedente 2 :2019
## 1st Qu.:2355 Fundo 2:2627 Produto 2: 190 Cedente 1 :1499
## Median :4709 Fundo 3: 306 Produto 3: 245 Cedente 17:1029
## Mean :4709 Fundo 4: 471 Produto 4: 4 Cedente 9 : 976
## 3rd Qu.:7062 Fundo 5: 4 Produto 5:1109 Cedente 20: 510
## Max. :9415 Cedente 3 : 490
## (Other) :2890
## SACADO LIMITE_CEDENTE ESTADO_CEDENTE ESTADO_SACADO
## Sacado 181: 194 Min. : 0 CE :3305 SP :3207
## Sacado 8 : 93 1st Qu.: 2500000 SP :2904 MG :1137
## Sacado 1 : 51 Median : 6964286 RS :1125 RS : 807
## Sacado 12 : 35 Mean : 5753487 GO : 609 PR : 684
## Sacado 2 : 25 3rd Qu.: 8035714 MG : 567 SC : 454
## Sacado 90 : 19 Max. :10000000 RJ : 305 CE : 423
## (Other) :8996 (Other): 598 (Other):2701
## VENCIMENTO DATA_EMISSAO DATA_PAGAMENTO
## Min. :2017-12-18 Min. :2016-05-02 Min. :2017-11-24
## 1st Qu.:2018-03-01 1st Qu.:2017-12-13 1st Qu.:2018-03-01
## Median :2018-05-19 Median :2018-03-10 Median :2018-05-18
## Mean :2018-05-19 Mean :2018-02-25 Mean :2018-05-18
## 3rd Qu.:2018-07-31 3rd Qu.:2018-05-17 3rd Qu.:2018-07-30
## Max. :2021-06-14 Max. :2018-09-23 Max. :2021-06-16
##
## VALOR_REAL VALOR_DESAGIO TAXA_MENSAL RISCO_1
## Min. : 17.2 Min. : 0.17 Min. :-0.53232 Min. :0.00000
## 1st Qu.: 481.0 1st Qu.: 31.91 1st Qu.: 0.02364 1st Qu.:0.06553
## Median : 978.1 Median : 77.31 Median : 0.03464 Median :0.21346
## Mean : 6434.2 Mean : 485.79 Mean : 0.04630 Mean :0.36856
## 3rd Qu.: 2868.0 3rd Qu.: 205.13 3rd Qu.: 0.05473 3rd Qu.:0.66577
## Max. :3112000.0 Max. :163116.72 Max. : 2.32065 Max. :1.00000
##
## RISCO_2 RISCO_3 RISCO_5 RISCO_7
## Min. :0.0000 Min. :0.000000 Min. :0.000000 Min. :0.000000
## 1st Qu.:0.3333 1st Qu.:0.000000 1st Qu.:0.000000 1st Qu.:0.000000
## Median :0.5000 Median :0.000000 Median :0.000000 Median :0.000000
## Mean :0.5917 Mean :0.095632 Mean :0.002229 Mean :0.000891
## 3rd Qu.:1.0000 3rd Qu.:0.000062 3rd Qu.:0.000000 3rd Qu.:0.000000
## Max. :1.0000 Max. :1.000000 Max. :1.000000 Max. :1.000000
##
## RISCO_8 RISCO_9 RISCO_11 RISCO_13
## Min. :0.0000704 Min. :0.000000 Min. :0.00000 Min. :0.0000
## 1st Qu.:0.2485020 1st Qu.:0.000000 1st Qu.:0.00000 1st Qu.:0.3322
## Median :0.4943268 Median :0.000002 Median :0.00000 Median :0.4741
## Mean :0.4963664 Mean :0.004113 Mean :0.08803 Mean :0.4143
## 3rd Qu.:0.7407853 3rd Qu.:0.001247 3rd Qu.:0.00000 3rd Qu.:0.5252
## Max. :0.9999736 Max. :1.000000 Max. :1.00000 Max. :1.0000
## NA's :40
## RISCO_14 RISCO_15 RISCO_16 RISCO_17
## Min. :0.00000 Min. :0.0000 Min. :0.0000 Min. :0.000000
## 1st Qu.:0.00000 1st Qu.:0.1333 1st Qu.:0.2000 1st Qu.:0.003556
## Median :0.00000 Median :0.2000 Median :0.4000 Median :0.018831
## Mean :0.01424 Mean :0.1974 Mean :0.4703 Mean :0.122281
## 3rd Qu.:0.00000 3rd Qu.:0.2667 3rd Qu.:0.6000 3rd Qu.:0.073831
## Max. :1.00000 Max. :1.0000 Max. :1.0000 Max. :1.000000
##
## RISCO_18 RISCO_19 RISCO_20 RISCO_21
## Min. :0.000000 Min. :0.0000 Min. :0.0000 Min. :0.0000
## 1st Qu.:0.003205 1st Qu.:0.3827 1st Qu.:0.8221 1st Qu.:0.4173
## Median :0.020265 Median :0.3827 Median :0.8856 Median :0.8303
## Mean :0.123076 Mean :0.3883 Mean :0.8267 Mean :0.6786
## 3rd Qu.:0.076833 3rd Qu.:0.3951 3rd Qu.:0.9763 3rd Qu.:0.9647
## Max. :1.000000 Max. :1.0000 Max. :1.0000 Max. :1.0000
## NA's :137
## STATUS_LIQ_TITULO ANO
## ATRASO:1867 2017: 65
## EM_DIA:7546 2018:9283
## 2019: 55
## 2020: 9
## 2021: 1
##
## Vale destacar que as variáveis VALOR_REAL, VALOR_DESAGIO tem 75% dos seus dados abaixo de 3000 e 200 respectivamente, mas possuem valores extremos chegando a mais de 100 mil e 3 milhões.
Qual fundo trouxe o maior retorno em desagio ?
# Qual fundo trouxe o maior retorno em Desagio?
x=group_by(df,ANO,NOME_FUNDO) %>%
summarise(DESAGIO=sum(VALOR_DESAGIO))## `summarise()` regrouping output by 'ANO' (override with `.groups` argument)x$NOME_FUNDO = as.factor(x$NOME_FUNDO)
ggplot(x, aes(x=NOME_FUNDO,y=DESAGIO)) + geom_boxplot() + theme_classic() + labs(title="Qual fundo trouxe o maior retorno em Desagio ?") + xlab("Fundos") +
ylab("Desagio")
O boxplot nos permite vizualizar que não só o fundo 1 trouxe o maior retonor mas também ele também possui uma rentabilidade mais distribuida em torno da mediana. Já o segundo fundo tem metades dos desagios trazendo baixíssimos retorno enquanto a outra metade cresce a valores autissímos.
Qual produto trouxe o maior retorno ?
# Qual fundo trouxe o maior retorno por ano?
x=group_by(df,ANO,NOME_FUNDO,TIPO_PRODUTO) %>%
summarise(DESAGIO=sum(VALOR_DESAGIO))## `summarise()` regrouping output by 'ANO', 'NOME_FUNDO' (override with `.groups` argument)x$NOME_FUNDO = as.factor(x$NOME_FUNDO)
ggplot(x, aes(x=TIPO_PRODUTO,y=DESAGIO, fill=TIPO_PRODUTO)) + geom_col() + theme_classic() + facet_wrap(x$NOME_FUNDO) + scale_y_continuous(labels = function(x) format(x, scientific = FALSE)) + theme(legend.direction = "vertical", axis.text.x = element_text(angle=-90)) +
labs(title="Qual Produto trouxe o maior retorno por Tipo de fundo ?") + xlab("Tipo de produto") + ylab("Desagio")
O fundo 1 (o que trás os maiores retornos) operam oferecendo os produtos 1 e produto 2 enquanto o fundo 2 que segue logo em seguida tem seus maiores retornos a partir do produto 3.
Em média qual tipo de produto ofertado trás o maior retorno ?
x=aggregate(df[,"TAXA_MENSAL"], list(local=df$TIPO_PRODUTO),trim=0.1,mean)
x=x[order(x[,2],decreasing = T),]
x$indice=c(1:5)
colnames(x)= c("Produtos","Media","Indice")
x$Produtos = as.factor(x$Produtos)
ggplot(x,aes(x=reorder(Produtos,-Indice),y=Media, color=Produtos)) +
geom_segment(aes(xend=Produtos, yend=0), show.legend = F) +
geom_point(aes(size=Media),show.legend = F)+
geom_label(aes(label=paste0(Media)),
fill="white",
hjust="inward",
show.legend = F)+
coord_flip()+
theme_minimal() +
labs(title = "Quais produtos em média trouxeram a maior taxa de retorno ?") +
ylab("Tipo de produtos") + xlab("Média Aparada")
Utilizando a média aparada em 10%, o gráfico acima mostra que o produto 3 trás os maiores retonos o que explica o mótivo do fundo 2 ter um valor de deságio tão exparsos já que esse fundo é o único que comercializou o produto 3.
Qual a média entre a taxa de retorno dos investimentos em dia e em atraso ?
Para avaliarmos qual situação tem a maior taxa de retorno inicialmente irei utilizar um simples boxplot. Para conseguir identificar a distriuição dos dados em torno da mediana restringir o eixo y de 0 até 0.25. Embora tenha retirado 56 outlines da analise ficou mais fácil de identificar que tem uma chance da taxa média de retorno é estatisticamente significativa
ggplot(data=df, aes(x=STATUS_LIQ_TITULO,y=TAXA_MENSAL)) + geom_boxplot() + ylim(c(0,0.25))## Warning: Removed 56 rows containing non-finite values (stat_boxplot).
Para termos certeza utilizei o teste estatistico de permutação aleatoria onde os dados serão divididos em duas classes (Em dia, Atraso), este teste é útil pois não precisamos nos preocupar com a distribuição dos dados, tamanho da amostra e se os dados são igualmente distribuidos.
Em_dia=subset(df,df$STATUS_LIQ_TITULO=="EM_DIA")
Atraso=subset(df,df$STATUS_LIQ_TITULO=="ATRASO")Agora será calculado a diferença entre as médias dos dois grupos
media_em_dia=mean(Em_dia$TAXA_MENSAL, trim = 0.1)
media_atraso=mean(Atraso$TAXA_MENSAL,trim = 0.1)
c(media_atraso,media_em_dia)## [1] 0.03227893 0.04071283media_diff= 100000*(media_em_dia-media_atraso)
media_diff## [1] 843.3904Abaixo segue o código utilizado para o teste de permutação, onde foi considerado a hipótese Ho como verdadeira (Não há diferênça entre as médias). Com base nisso retiramos 1000 vezes de forma aleatoria dois grupos (n1 e n2) e calculamos a média para ver a distribuição da diferença desses valores e comparar com a diferença calculada sem a permutação para encontrar as chances de o acaso ser responsável por essa variação no valor do aluguel.
#Tamanho da amostra em dia
length(Em_dia$CODIGO)## [1] 7546#Tamanho da amostra atraso
length(Atraso$CODIGO)## [1] 1867Agora será criado a função que utilizarei para fazer os testes de hipóteses
# tamanho total de 9413
perm_fun = function(x,n1,n2){
n= n1 + n2
idx_b = sample(1:n,n1)
idx_a= setdiff(1:n,idx_b)
mean_diff= mean(x[idx_b],trim = 0.1)- mean(x[idx_a],trim = 0.1)
return(100000*mean_diff)
}
perm_diffs=rep(0,1000)
for(i in 1:1000){
perm_diffs[i]= perm_fun(df$TAXA_MENSAL,7546,1867)}
hist(perm_diffs,nclass = 80,xlim = c(-200,1000))
abline(v=(media_diff))
Fica claro que nenhum valor aleatorio da diferença entre as médias chegou perto da diferença encontrada entre a taxa mensal dos que pagam em dia e os que pagam atrasados. Para oficializarmos o teste de hipótese o valor p estar calculado abaixo:
p=mean(perm_diffs>media_diff)
p## [1] 0Com um valor p=0 podemos rejeitar a hipotese nula (ho) de que a diferença entre as médias da taxa mensal dos dois grupos foi ocasionada por um fator aleatório.
Como esta distribuido o valor do DESAGiO recebido pela empresa ?
74% do valor do Desagio de acumula entre R\(0 a R\) 250 reais. A frequencia dos valores vai caindo e depois de R$ 3000 são casos mais pontuais. Esse comportamento determina que o modelo de negócio utilizado foca na quantidade de produtos vendidos.
hist(df$VALOR_DESAGIO, nclass = 600, xlim = c(0,3000), labels = TRUE)
Como está distribuido a demanda com base na data de emissão ?
Agrupei os dados pela data de Emissão por ser a melhor tipo de data em comparação as outras disponivéis no dataset para analisarmos a demanda da empresa.
dados= group_by(df,DATA_EMISSAO) %>%
summarise(VALOR_DESAGIO=length(VALOR_DESAGIO))## `summarise()` ungrouping output (override with `.groups` argument)dados$DATA_EMISSAO=ymd(dados$DATA_EMISSAO)
serie= ts(dados$VALOR_DESAGIO,start = c(2016,5), end = c(2018,9),frequency = 12)plot(serie, xlab="Anos", ylab="Número de serviços feitos") +
title("Demanda ao longo do tempo")
## integer(0)A maior parte da demanda investigada ocorre no periodo de 2017. Para entendermos melhor o comportamento do gráfico ao longo do tempo irei decompor a serie temporal em parcelas sazonais.
ggseasonplot(serie,year.labels = T, year.labels.left = T) + ylab("Demanda por Mês") +
xlab("Periodo") + ggtitle("Parcelas Sazonais")+
theme_classic()
Observando os valores de demanda ao longo dos meses não parece existir nenhum padrão claro, a principio parece que a demanda estudada segue um comportamento aleatório. Para concluir a análise utilizarei o método de decomposição STL que tem o objetivo de separar os componentes da serie em tendência, sazonalidade e resto.
fit= stl(serie, t.window = 13, s.window = "periodic", robust = T)
autoplot(fit)
A decomposição fica bem enviesada pela falta de dados no inicio de de 2016 e no fim de 2017
Onde estar concentrado o maior numero de clientes ?
x_cedente= group_by(df,ESTADO_CEDENTE) %>%
summarise(DEMANDA=length(VALOR_DESAGIO))## `summarise()` ungrouping output (override with `.groups` argument)x_cedente=x_cedente[order(x_cedente[,2],decreasing = T),]
x_cedente$indice=c(1:length(x_cedente$DEMANDA))
x_sacado= group_by(df,ESTADO_SACADO) %>%
summarise(DEMANDA= length(VALOR_DESAGIO))## `summarise()` ungrouping output (override with `.groups` argument)x_sacado=x_sacado[order(x_sacado[,2],decreasing = T),]
x_sacado$indice=c(1:length(x_sacado$DEMANDA))
par(mfrow=c(1,2))
ggplotly(ggplot(x_cedente, aes(x=reorder(ESTADO_CEDENTE, -indice), y=DEMANDA)) + geom_col() + coord_flip() + theme_classic()+ labs(title = "Quais estados são os Cedentes da REDASSET") + xlab("Estados")+ ylab("Demanda"))ggplotly(ggplot(x_sacado, aes(x=reorder(ESTADO_SACADO,-indice), y=DEMANDA)) + geom_col() + coord_flip()+ theme_classic()+ labs(title = "Quais estados são os Sacados da REDASSET") + xlab("Demanda") + ylab("Estados"))Em que dia da semana a REDAsset tem sua maior demanda ?
Criarei a feature dia da semana como uma variável global pois talvez ela nos seja útil para prever algum resultado nos proximos exercicios.
df$DIA_SEMANA=weekdays(as.Date(df$DATA_EMISSAO), abbreviate = TRUE)
df$DIA_SEMANA= as.factor(df$DIA_SEMANA)
x= group_by(df,DATA_EMISSAO,DIA_SEMANA,TIPO_PRODUTO) %>%
summarise(DEMANDA=length(VALOR_DESAGIO))## `summarise()` regrouping output by 'DATA_EMISSAO', 'DIA_SEMANA' (override with `.groups` argument)ggplot(x,aes(x=DIA_SEMANA, y=DEMANDA, fill=DIA_SEMANA)) + geom_col() + theme_classic() +
xlab("DIA DA SEMANA") + labs(title="Demanda por dia da semana") + facet_wrap(as.factor(x$TIPO_PRODUTO))
O gráfico mostra que os principais dia de alta na demanda são quarta e quinta utilizando como data de referência da data de emissão;
Exercicio 2
Seleção de Features
Inicialmente irei colocar as variaveis que trabalharei no problema, não utilizei as variaveis de risco.
dados=df[1:14]
dados$DIA_SEMANA=df$DIA_SEMANA
dados$STATUS_LIQ_TITULO=df$STATUS_LIQ_TITULO
dados$CODIGO=NULL
#s=c("DATA_PAGAMENTO","DATA_EMISSAO","VENCIMENTO")
dados$DATA_EMISSAO=NULL
dados$DATA_PAGAMENTO=NULL
dados$VENCIMENTO=NULL
#s=colnames(sapply(dados, as.character))
#for(i in 1:length(s)){
# dados[,s[i]]=as.factor(dados[,s[i]])
#}
dados$LIMITE_CEDENTE=as.numeric(dados$LIMITE_CEDENTE)
dados$VALOR_REAL= as.numeric(dados$VALOR_REAL)
dados$VALOR_DESAGIO=as.numeric(dados$VALOR_DESAGIO)
dados$TAXA_MENSAL=as.numeric(dados$TAXA_MENSAL)
summary(dados)## NOME_FUNDO TIPO_PRODUTO CEDENTE SACADO
## Fundo 1:6005 Produto 1:7865 Cedente 2 :2019 Sacado 181: 194
## Fundo 2:2627 Produto 2: 190 Cedente 1 :1499 Sacado 8 : 93
## Fundo 3: 306 Produto 3: 245 Cedente 17:1029 Sacado 1 : 51
## Fundo 4: 471 Produto 4: 4 Cedente 9 : 976 Sacado 12 : 35
## Fundo 5: 4 Produto 5:1109 Cedente 20: 510 Sacado 2 : 25
## Cedente 3 : 490 Sacado 90 : 19
## (Other) :2890 (Other) :8996
## LIMITE_CEDENTE ESTADO_CEDENTE ESTADO_SACADO VALOR_REAL
## Min. : 0 CE :3305 SP :3207 Min. : 17.2
## 1st Qu.: 2500000 SP :2904 MG :1137 1st Qu.: 481.0
## Median : 6964286 RS :1125 RS : 807 Median : 978.1
## Mean : 5753487 GO : 609 PR : 684 Mean : 6434.2
## 3rd Qu.: 8035714 MG : 567 SC : 454 3rd Qu.: 2868.0
## Max. :10000000 RJ : 305 CE : 423 Max. :3112000.0
## (Other): 598 (Other):2701
## VALOR_DESAGIO TAXA_MENSAL DIA_SEMANA STATUS_LIQ_TITULO
## Min. : 0.17 Min. :-0.53232 dom: 811 ATRASO:1867
## 1st Qu.: 31.91 1st Qu.: 0.02364 qua:1695 EM_DIA:7546
## Median : 77.31 Median : 0.03464 qui:1645
## Mean : 485.79 Mean : 0.04630 sáb: 848
## 3rd Qu.: 205.13 3rd Qu.: 0.05473 seg:1414
## Max. :163116.72 Max. : 2.32065 sex:1493
## ter:1507Além dessas, agruparei os sacados e cedentes em grupos utilizando como referência os quantis a cada 10% do VALOR_REAL e o LIMITE_CEDENTE por achar que as duas variáveis podem conseguir separar os dois grupos com base no tamanho das empresas tendo em vista se um cedente tem um Limite alto indica que ele tem um poder aquisitivo grande e se um Sacado vai receber um valor alto indica que ele possa ter um faturamento mensal alto.
Criando classificação para os cedentes
grupo_Sacados = function(x){
if (x <quantile(df$VALOR_REAL,0.10)){
return(1)
}
if (x>=quantile(df$VALOR_REAL,0.10) & x<quantile(df$VALOR_REAL,0.20)){
return(2)
}
if (x>=quantile(df$VALOR_REAL,0.20) & x<quantile(df$VALOR_REAL,0.30)){
return(3)
}
if (x>=quantile(df$VALOR_REAL,0.30) & x<quantile(df$VALOR_REAL,0.40)){
return(4)
}
if (x>=quantile(df$VALOR_REAL,0.40) & x<quantile(df$VALOR_REAL,0.50)){
return(5)
}
if (x>=quantile(df$VALOR_REAL,0.50) & x<quantile(df$VALOR_REAL,0.60)){
return(6)
}
if (x>=quantile(df$VALOR_REAL,0.60) & x<quantile(df$VALOR_REAL,0.70)){
return(7)
}
if (x>=quantile(df$VALOR_REAL,0.70) & x<quantile(df$VALOR_REAL,0.80)){
return(8)
}
if (x>=quantile(df$VALOR_REAL,0.80)){
return(9)
}}
grupo_Cedentes =function(x){
if (x <quantile(df$LIMITE_CEDENTE,0.10)){
return(1)
}
if (x>=quantile(df$LIMITE_CEDENTE,0.10) & x<quantile(df$LIMITE_CEDENTE,0.20)){
return(2)
}
if (x>=quantile(df$LIMITE_CEDENTE,0.20) & x<quantile(df$LIMITE_CEDENTE,0.30)){
return(3)
}
if (x>=quantile(df$LIMITE_CEDENTE,0.30) & x<quantile(df$LIMITE_CEDENTE,0.40)){
return(4)
}
if (x>=quantile(df$LIMITE_CEDENTE,0.40) & x<quantile(df$LIMITE_CEDENTE,0.50)){
return(5)
}
if (x>=quantile(df$LIMITE_CEDENTE,0.50) & x<quantile(df$LIMITE_CEDENTE,0.60)){
return(6)
}
if (x>=quantile(df$LIMITE_CEDENTE,0.60) & x<quantile(df$LIMITE_CEDENTE,0.70)){
return(7)
}
if (x>=quantile(df$LIMITE_CEDENTE,0.70) & x<quantile(df$LIMITE_CEDENTE,0.80)){
return(8)
}
if (x>=quantile(df$LIMITE_CEDENTE,0.80)){
return(9)
}}
df$grupoSacados=mapply(grupo_Sacados,df$VALOR_REAL)
df$grupoCedentes=mapply(grupo_Cedentes,df$LIMITE_CEDENTE)
df$grupoCedentes = as.factor(df$grupoCedentes)
df$grupoSacados=as.factor(df$grupoSacados)
dados$grupoSacados=df$grupoSacados
dados$grupoCedentes=df$grupoCedentesPré processamento e geração da classe dist
Para os dados será utilizado a distancia de gower, esse método é o mais indicado quando temos variaveis numericas e categoricas para algoritmos não supervisonados pois ele vai criar uma escala diferente para os valores categoricos e outra para variáveis numericas.
library(cluster)
dados_transformados=daisy(dados,metric="gower")Algoritmo não supervisionado
O método escolhido foi de agrupamento hieráquico por ser mais flexível que o k-means e acomodar mais facilmente variáveis não numericas. A desvantagem é que o método usa um esforço computacional bem maior, mas como o dataset não é muito grande é possível utiliza-lo.Para definir o metodo de agrupamento optei por utilizar a função coefHier, ela me permite calcular o coeficiente de aglomeração, que mede a quantidade de estrututa de agrupamento encontrada (valores próximos a 1 indicam uma estrutura de agrupamento forte)
m <- c( "average", "single", "complete", "ward.D2")
names(m) <- c( "average", "single", "complete", "ward")
ac <- function(x) {
hcl=hclust(dados_transformados, method = x)
coefHier(hcl)
}
map_dbl(m, ac)## average single complete ward
## 0.8248256 0.7399224 0.8624271 0.9914120O método que trouxe o maior coeficiente de aglomeração foi o Ward que miminiza a soma dos quadrados dentro do grupo semelhante ao método por k-means. Em seguida criarei o modelo
hcl=hclust(dados_transformados, method = "ward.D2")Para determinar o k de corte no agrupamento hierarquico decidir utilizar o metodo da silheta que reflete a qualidade da alocação dos dados em cada grupos.
grupos <- hcut(dados_transformados, k = 15, hc_method = "ward.D2")
fviz_silhouette(grupos)## cluster size ave.sil.width
## 1 1 1629 0.19
## 2 2 1499 0.41
## 3 3 390 0.21
## 4 4 869 0.12
## 5 5 1022 0.54
## 6 6 305 0.38
## 7 7 257 0.60
## 8 8 561 0.10
## 9 9 150 0.49
## 10 10 971 0.38
## 11 11 280 0.13
## 12 12 459 0.42
## 13 13 510 0.38
## 14 14 306 0.34
## 15 15 205 0.43
Usando o método da silheta, temos que o melhor agrupamento é com k=7 pois produz a melhor média de agrupamento com 0.6. É possível notar também valores negativos ocasionados por outlines.
plot(hcl, cex = 0.6)
rect.hclust(hcl, k = 7, border = 2:5)
Passando as informações dos grupos para os dados
df$Grupos=cutree(hcl,k=7)
dados$Grupos=as.factor(cutree(hcl,k=7))Exercicio 3
df$ANO=year(df$VENCIMENTO)
df$MES = month(df$VENCIMENTO)
df$DIA = day(df$VENCIMENTO)
df$ANO= as.factor(df$ANO)
df$MES=as.factor(df$MES)Para esse exercício continuarei com as variáveis criadas e aproveitarei os grupos criados na etapa anterior.
ex_3=dfValores faltantes
colSums(is.na(df))/length(df$CODIGO)*100## CODIGO NOME_FUNDO TIPO_PRODUTO CEDENTE
## 0.0000000 0.0000000 0.0000000 0.0000000
## SACADO LIMITE_CEDENTE ESTADO_CEDENTE ESTADO_SACADO
## 0.0000000 0.0000000 0.0000000 0.0000000
## VENCIMENTO DATA_EMISSAO DATA_PAGAMENTO VALOR_REAL
## 0.0000000 0.0000000 0.0000000 0.0000000
## VALOR_DESAGIO TAXA_MENSAL RISCO_1 RISCO_2
## 0.0000000 0.0000000 0.0000000 0.0000000
## RISCO_3 RISCO_5 RISCO_7 RISCO_8
## 0.0000000 0.0000000 0.0000000 0.0000000
## RISCO_9 RISCO_11 RISCO_13 RISCO_14
## 0.0000000 0.0000000 0.4249442 0.0000000
## RISCO_15 RISCO_16 RISCO_17 RISCO_18
## 0.0000000 0.0000000 0.0000000 0.0000000
## RISCO_19 RISCO_20 RISCO_21 STATUS_LIQ_TITULO
## 1.4554340 0.0000000 0.0000000 0.0000000
## ANO DIA_SEMANA grupoSacados grupoCedentes
## 0.0000000 0.0000000 0.0000000 0.0000000
## Grupos MES DIA
## 0.0000000 0.0000000 0.0000000Utilizarei o método de regressão linear para substituir os dados faltantes na variável RISCO_13, adianto que não é necessário pois a quantidade de outlines é muito baixa, mas trago uma maneira diferente de fazer o tratamento de outlines. Além disso retirarei as variáveis SACADO, CEDENTE e VENCIMENTO pois as novas features que adicionei coletam informações delas.
#Prevendo para Risco 13
ex_3$SACADO=NULL
ex_3$CEDENTE=NULL
ex_3$VENCIMENTO=NULL
modelo<- na.omit(ex_3)
preverrisco13 <- lm(RISCO_13~., data=modelo)
summary(preverrisco13)##
## Call:
## lm(formula = RISCO_13 ~ ., data = modelo)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.39360 -0.04234 -0.00603 0.03228 0.55103
##
## Coefficients: (1 not defined because of singularities)
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -7.097e+00 3.410e+00 -2.082 0.037412 *
## CODIGO 2.231e-06 3.337e-07 6.685 2.44e-11 ***
## NOME_FUNDOFundo 2 3.079e-03 4.564e-03 0.675 0.499885
## NOME_FUNDOFundo 3 6.578e-03 6.205e-03 1.060 0.289152
## NOME_FUNDOFundo 4 -3.911e-03 6.070e-03 -0.644 0.519307
## NOME_FUNDOFundo 5 2.413e-01 3.953e-02 6.104 1.08e-09 ***
## TIPO_PRODUTOProduto 2 9.523e-03 6.548e-03 1.454 0.145889
## TIPO_PRODUTOProduto 3 9.275e-03 1.090e-02 0.851 0.394747
## TIPO_PRODUTOProduto 4 NA NA NA NA
## TIPO_PRODUTOProduto 5 1.047e-01 1.228e-02 8.526 < 2e-16 ***
## LIMITE_CEDENTE 4.953e-08 4.898e-09 10.112 < 2e-16 ***
## ESTADO_CEDENTECE -3.341e-02 1.551e-02 -2.154 0.031241 *
## ESTADO_CEDENTEGO 9.382e-03 9.406e-03 0.998 0.318528
## ESTADO_CEDENTEMG -6.949e-02 1.358e-02 -5.116 3.18e-07 ***
## ESTADO_CEDENTEMT -4.840e-02 1.960e-02 -2.470 0.013542 *
## ESTADO_CEDENTEPA 1.822e-02 1.636e-02 1.114 0.265474
## ESTADO_CEDENTERJ -1.778e-02 8.859e-03 -2.007 0.044757 *
## ESTADO_CEDENTERS -3.749e-02 8.326e-03 -4.503 6.77e-06 ***
## ESTADO_CEDENTESC -6.898e-02 1.005e-02 -6.861 7.27e-12 ***
## ESTADO_CEDENTESE -3.210e-02 2.922e-02 -1.099 0.271963
## ESTADO_CEDENTESP -2.749e-02 7.942e-03 -3.461 0.000540 ***
## ESTADO_SACADOAC 8.381e-02 3.520e-02 2.381 0.017274 *
## ESTADO_SACADOAL 3.547e-03 1.329e-02 0.267 0.789560
## ESTADO_SACADOAM 2.586e-02 1.542e-02 1.677 0.093591 .
## ESTADO_SACADOAP 3.777e-02 2.812e-02 1.343 0.179268
## ESTADO_SACADOBA 1.415e-02 8.418e-03 1.681 0.092731 .
## ESTADO_SACADOCE 2.092e-02 8.299e-03 2.521 0.011712 *
## ESTADO_SACADODF 1.559e-02 9.447e-03 1.650 0.098943 .
## ESTADO_SACADOES 2.642e-02 1.015e-02 2.601 0.009302 **
## ESTADO_SACADOGO 1.825e-02 7.975e-03 2.288 0.022165 *
## ESTADO_SACADOMA 2.439e-02 1.025e-02 2.380 0.017325 *
## ESTADO_SACADOMG 2.330e-02 7.443e-03 3.130 0.001752 **
## ESTADO_SACADOMS 2.122e-02 1.185e-02 1.791 0.073332 .
## ESTADO_SACADOMT 2.885e-02 9.454e-03 3.051 0.002286 **
## ESTADO_SACADOPA 2.193e-02 9.483e-03 2.313 0.020755 *
## ESTADO_SACADOPB 1.590e-02 1.051e-02 1.513 0.130282
## ESTADO_SACADOPE 1.772e-02 9.184e-03 1.929 0.053742 .
## ESTADO_SACADOPI 3.013e-02 1.196e-02 2.519 0.011786 *
## ESTADO_SACADOPR 1.591e-02 7.817e-03 2.036 0.041787 *
## ESTADO_SACADORJ 1.463e-02 8.179e-03 1.788 0.073731 .
## ESTADO_SACADORN 1.854e-02 1.028e-02 1.803 0.071355 .
## ESTADO_SACADORO 1.359e-02 1.484e-02 0.916 0.359732
## ESTADO_SACADORR 3.695e-02 7.740e-02 0.477 0.633040
## ESTADO_SACADORS 1.874e-02 7.863e-03 2.383 0.017197 *
## ESTADO_SACADOSC 1.961e-02 8.122e-03 2.414 0.015804 *
## ESTADO_SACADOSE 9.598e-03 1.231e-02 0.780 0.435634
## ESTADO_SACADOSP 2.044e-02 7.292e-03 2.804 0.005062 **
## ESTADO_SACADOTO 3.715e-02 1.278e-02 2.906 0.003664 **
## DATA_EMISSAO 3.419e-04 2.082e-05 16.419 < 2e-16 ***
## DATA_PAGAMENTO 9.133e-05 1.969e-04 0.464 0.642777
## VALOR_REAL -6.765e-08 4.972e-08 -1.360 0.173718
## VALOR_DESAGIO 6.343e-07 7.282e-07 0.871 0.383760
## TAXA_MENSAL 6.836e-02 1.727e-02 3.958 7.60e-05 ***
## RISCO_1 3.914e-02 5.508e-03 7.107 1.28e-12 ***
## RISCO_2 -4.726e-02 6.431e-03 -7.350 2.16e-13 ***
## RISCO_3 -4.515e-02 4.636e-03 -9.739 < 2e-16 ***
## RISCO_5 4.201e-01 3.285e-02 12.789 < 2e-16 ***
## RISCO_7 -1.183e+00 6.952e-02 -17.016 < 2e-16 ***
## RISCO_8 2.842e-03 2.806e-03 1.013 0.311215
## RISCO_9 2.575e+00 9.778e-02 26.331 < 2e-16 ***
## RISCO_11 4.180e-02 1.114e-02 3.752 0.000176 ***
## RISCO_14 -2.306e-02 1.106e-02 -2.085 0.037137 *
## RISCO_15 1.341e-01 1.677e-02 7.996 1.44e-15 ***
## RISCO_16 -2.851e-02 8.407e-03 -3.391 0.000698 ***
## RISCO_17 1.075e+00 1.080e-01 9.947 < 2e-16 ***
## RISCO_18 -1.074e+00 1.077e-01 -9.978 < 2e-16 ***
## RISCO_19 6.733e-02 2.999e-02 2.245 0.024802 *
## RISCO_20 4.309e-02 6.561e-03 6.567 5.41e-11 ***
## RISCO_21 8.208e-04 2.441e-03 0.336 0.736706
## STATUS_LIQ_TITULOEM_DIA 3.651e-04 2.486e-03 0.147 0.883257
## ANO2018 -1.210e-01 7.366e-02 -1.643 0.100383
## ANO2019 -1.550e-01 1.449e-01 -1.070 0.284782
## ANO2020 -1.783e-01 2.178e-01 -0.819 0.412900
## ANO2021 -1.958e-01 2.980e-01 -0.657 0.511113
## DIA_SEMANAqua -1.032e-03 3.342e-03 -0.309 0.757376
## DIA_SEMANAqui 6.071e-03 3.362e-03 1.806 0.070949 .
## DIA_SEMANAsáb -1.815e-03 3.843e-03 -0.472 0.636679
## DIA_SEMANAseg 2.110e-03 3.435e-03 0.614 0.539113
## DIA_SEMANAsex 3.294e-03 3.420e-03 0.963 0.335481
## DIA_SEMANAter 1.512e-03 3.394e-03 0.446 0.655916
## grupoSacados2 -1.132e-02 3.738e-03 -3.029 0.002460 **
## grupoSacados3 -8.981e-03 3.899e-03 -2.303 0.021296 *
## grupoSacados4 -1.029e-02 3.995e-03 -2.577 0.009991 **
## grupoSacados5 -5.268e-03 3.906e-03 -1.349 0.177465
## grupoSacados6 -5.463e-03 3.965e-03 -1.378 0.168254
## grupoSacados7 -4.014e-03 4.017e-03 -0.999 0.317731
## grupoSacados8 -7.436e-03 4.053e-03 -1.835 0.066574 .
## grupoSacados9 -5.659e-03 3.910e-03 -1.447 0.147905
## grupoCedentes2 -5.274e-02 8.803e-03 -5.991 2.16e-09 ***
## grupoCedentes3 -8.579e-02 1.135e-02 -7.559 4.44e-14 ***
## grupoCedentes4 -1.055e-01 1.242e-02 -8.501 < 2e-16 ***
## grupoCedentes5 -1.617e-01 1.931e-02 -8.374 < 2e-16 ***
## grupoCedentes6 -2.826e-01 3.093e-02 -9.139 < 2e-16 ***
## grupoCedentes8 -4.384e-01 4.053e-02 -10.814 < 2e-16 ***
## grupoCedentes9 -6.835e-01 4.853e-02 -14.085 < 2e-16 ***
## Grupos 7.673e-03 2.702e-03 2.840 0.004519 **
## MES2 -2.570e-02 6.951e-03 -3.697 0.000219 ***
## MES3 -6.734e-02 1.223e-02 -5.508 3.73e-08 ***
## MES4 -1.151e-01 1.824e-02 -6.308 2.96e-10 ***
## MES5 -1.392e-01 2.409e-02 -5.778 7.81e-09 ***
## MES6 -1.352e-01 3.018e-02 -4.481 7.51e-06 ***
## MES7 -1.148e-01 3.602e-02 -3.186 0.001445 **
## MES8 -8.915e-02 4.218e-02 -2.114 0.034556 *
## MES9 -5.436e-02 4.829e-02 -1.126 0.260298
## MES10 -9.176e-02 5.340e-02 -1.719 0.085739 .
## MES11 -7.454e-02 6.070e-02 -1.228 0.219526
## MES12 -1.104e-01 6.753e-02 -1.634 0.102215
## DIA -4.691e-04 2.177e-04 -2.155 0.031209 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.07682 on 9129 degrees of freedom
## Multiple R-squared: 0.7959, Adjusted R-squared: 0.7935
## F-statistic: 335.9 on 106 and 9129 DF, p-value: < 2.2e-16O modelo criado conseguiu explicar 80% da variância dos dados,gerou também um R2 ajustado quase igual ao R2 o que implica que nosso modelo tem baixa multicolinearidade.
Utilizando o modelo acima para prever os dados faltantes
id <-subset(ex_3$CODIGO,is.na(ex_3$RISCO_13))
length(id)## [1] 40ex_3[id,"RISCO_13"]=predict(preverrisco13,ex_3[id,])Para finalizar retirarei as linhas que tenham algum valor faltante restante ligados a variável RISCO_XX pois as mesmas não representam um valor significativo comparado ao tamanho do dataset
#retirando resto dos dados faltantes
ex_3= na.omit(ex_3)Normalizando dados númericos
Para evitar problema com escalas diferentes normalizarei os dados númericos, isso fará com que os dados tenham o mesmo padrão na escala indo de -1 a 1 capiturando apenas a variação das features em relação a sua média.
ex_3[,sapply(ex_3, is.numeric)]=scale(ex_3[,sapply(ex_3, is.numeric)])
ex_3$CODIGO=NULLDesbalanceamento
Vendo diferença de classe
prop.table(table(ex_3$STATUS_LIQ_TITULO))##
## ATRASO EM_DIA
## 0.1961526 0.8038474É possível notar que as classes estão desbalanceadas com 80% dos dados classificados com EM_DIA, caso o modelo seja treinado com os dados desse jeito teremos um resultado enviezado. Para evitar esse problema utilizarei o método Oversample onde reamostrei a classe minoritária para gerar dados novos até balancear o dataset.
dados_balanceados=ovun.sample(STATUS_LIQ_TITULO ~ .,
data = ex_3,
seed = 123,
method = "over")$dataProporção das classes
prop.table(table(dados_balanceados$STATUS_LIQ_TITULO))##
## EM_DIA ATRASO
## 0.5036566 0.4963434Separando dados em treino e teste
#Divindo dados em treino e dados de teste
dados_balanceados$id<-1:length(dados_balanceados$NOME_FUNDO)
split<- createDataPartition(dados_balanceados$id,p=0.7, list=F)
dados_treino=dados_balanceados[split,]
dados_teste= dados_balanceados[-split,]
dados_treino$id=NULL
dados_teste$id=NULLCriando modelo
Utilizarei o método random Forest com 500 arvores treinadas (valor padrão do RandomForest)
#Criando modelo
rf= randomForest(as.factor(STATUS_LIQ_TITULO)~., data=dados_treino,importance=TRUE)Para entender quais features foram mais importântes para a criação do modelo, abaixo segue um gráfico que mostra a importância de cada feature utilizando o critério de gini que mede a inpureza dos dados.
varImpPlot(rf, type=2)
Logo a variável que mais contribui para separar os dados em grupos mais puros foi RISCO_21.
Matriz de confusão
prev_rf= predict(rf,dados_teste)
confusionMatrix(prev_rf,as.factor(dados_teste$STATUS_LIQ_TITULO))## Confusion Matrix and Statistics
##
## Reference
## Prediction EM_DIA ATRASO
## EM_DIA 2142 64
## ATRASO 88 2134
##
## Accuracy : 0.9657
## 95% CI : (0.9599, 0.9708)
## No Information Rate : 0.5036
## P-Value [Acc > NIR] : <2e-16
##
## Kappa : 0.9313
##
## Mcnemar's Test P-Value : 0.0621
##
## Sensitivity : 0.9605
## Specificity : 0.9709
## Pos Pred Value : 0.9710
## Neg Pred Value : 0.9604
## Prevalence : 0.5036
## Detection Rate : 0.4837
## Detection Prevalence : 0.4982
## Balanced Accuracy : 0.9657
##
## 'Positive' Class : EM_DIA
## Analisando a matriz de confusão, nosso modelo tem uma acertou 95% dos dados na base de teste. Para os casos em que O modelo preveu a classe positiva o mesmo acertou 96,44% o que é uma métrica muito boa. A sua especificidade que é a habilidade do modelo prever resultados negativos (EM_DIA) é de 95,28%
Outro índice importânte é o Kappa de 91% que compara o resultado do modelo criado em relação a um modelo teórico utilizando o crítério ao acaso. Em relação a esse índice nosso modelo é considerado excelente.