library(knitr)
require(xlsx)Obtem Tabela de Concessão.
tmp <- tempfile()
download.file("http://www.prefeitura.sp.gov.br/cidade/secretarias/upload/transportes/SPTrans/2014/janeiro/remuneracao/Concessao-010114.xlsx",
destfile=tmp, method="curl")
#Le a tabela em excel.
concessao.table <- read.xlsx(tmp, sheetIndex=1)
#Remove o arquivo temporario.
unlink(tmp)Obtem Tabela de Permissão
#Repete o mesmo processo para tabela de permissao.
tmp <- tempfile()
download.file("http://www.prefeitura.sp.gov.br/cidade/secretarias/upload/transportes/SPTrans/2014/janeiro/remuneracao/Permissao-010114.xls",
destfile=tmp, method="curl")
#Le a tabela em excel.
permissao.table <- read.xlsx(tmp, sheetIndex=1)
#Remove o arquivo temporario.
unlink(tmp)Obtem Tabela de Passageiros Transportados
tmp <- tempfile()
download.file("http://www.prefeitura.sp.gov.br/cidade/secretarias/upload/transportes/SPTrans/2014/janeiro/passageiros/Passag-20140101.xls",
destfile=tmp, method="curl")
#Le a tabela em excel.
passageiro.table <- read.xlsx(tmp, sheetIndex=1)
#Remove o arquivo temporario.
unlink(tmp)As tabelas de demonstrativos de remuneração contém mais informação do que precisamos para análise dos custos por passageiros. Se olharmos as duas tabelas de demonstrativos na Fonte, encontraremos um pouco que escondido nos itens 8 e 10 os custos das empresas.
Infelizmente, o nome e area das colunas não apenas não seguem um padrão, como também estão separados em uma ou duas linhas. Devido a formatação da tabela, a leitura em memoria gera colunas extras sem conteúdo. Este pre-processamento é feito aqui, mas acaso a quantidade de colunas mude, o que pode ser possível após o vencimento dos contratos em ambas as tabelas, esta limpeza pode não mais funcionar.
#library(stringr)
#Função para localizar e extrair somente os custos da empresa.
find.company.start.index <- function(regex,file){
#company.index <- grepl(pattern=string.to.find,x=file[,1],ignore.case=TRUE)
#company.index <- which(company.index == TRUE) + 1
#return(file[company.index:nrow(file),])
return(file[grepl(regex,file[,1]),])
}
#library("stringr")
#indices <- !is.na(str_match(words,'([9]).([0-9]).*')[,1])
clean.concessao.table.errors <- function(table){
#Remoção das ultimas duas colunas geradas por erro da leitura da tabela excel devido a formatacao original.
table <- table[,c(-ncol(table),-(ncol(table)-1))]
#Nomeação das Colunas (Arquivo original contem os nomes em mais de uma linha)
colnames(table) <- c("Empresa","Consórcio Bandeirante de Transporte","Sambaíba Transportes Urbanos Ltda.","Consórcio Plus","Via Sul Transportes Urbanos Ltda.","Consórcio Unisul","Consórcio Sete","Consórcio Sudoeste de Transporte","Ambiental Transp. Urb. S.A.","Express Transp. Urb Ltda","TOTAL")
return(table)
}
clean.permissao.table.errors <- function(table){
#Remoção das ultimas duas colunas geradas por erro da leitura da tabela excel devido a formatacao original.
table <- table[,c(-ncol(table),-(ncol(table)-1),-(ncol(table)-2))]
#Nomeação das Colunas
colnames(table) <- c("Empresa","Consórcio Transcooper Fênix","Consórcio Transcooper Fênix","Consórcio Aliança Paulistana","Transcooper","Consórcio Aliança Cooperpeople","Consórcio Auhto Pam","Consórcio Auhto Pam",
"Consórcio Unicoopers Cooperalfa")
return(table)
}
companies.concessao <- find.company.start.index('([8]).([0-9]).*',concessao.table)
companies.concessao <- clean.concessao.table.errors(companies.concessao)
companies.permissao <- find.company.start.index('([9]).([0-9]).*',permissao.table)
companies.permissao <- clean.permissao.table.errors(companies.permissao)Após a extração do que nos interessa, exibo aqui como ficaram os dados de 1/1/2014 nas três tabelas usadas referenciadas na Fonte.
kable(companies.concessao)| Empresa | Consórcio Bandeirante de Transporte | Sambaíba Transportes Urbanos Ltda. | Consórcio Plus | Via Sul Transportes Urbanos Ltda. | Consórcio Unisul | Consórcio Sete | Consórcio Sudoeste de Transporte | Ambiental Transp. Urb. S.A. | Express Transp. Urb Ltda | TOTAL | |
|---|---|---|---|---|---|---|---|---|---|---|---|
| 1 | OPERAÇÃO 01/01/14 - VENCIMENTO 08/01/14 | NA | NA | NA | NA | NA | NA | NA | NA | NA | NA |
| 100 | 8.1. Viação Gato Preto Ltda. | 23160.05 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 23160.05 |
| 101 | 8.2. Viação Santa Brígida Ltda. | 154368.05 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 154368.05 |
| 102 | 8.3. Sambaíba Transportes Urbanos Ltda. | 0 | 287799.4 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 287799.4 |
| 103 | 8.4. Consórcio Plus | 0 | 0 | 386448.75 | 0 | 0 | 0 | 0 | 0 | 0 | 386448.75 |
| 104 | 8.5. Via Sul Transportes Urbanos Ltda. | 0 | 0 | 0 | 170364.9 | 0 | 0 | 0 | 0 | 0 | 170364.9 |
| 105 | 8.6. VIP - Transportes Urbanos Ltda. | 0 | 0 | 0 | 0 | 42976.99 | 0 | 0 | 0 | 0 | 42976.99 |
| 106 | 8.7. Tupi Transportes Urbanos Piratininga Ltda. | 0 | 0 | 0 | 0 | 59091 | 0 | 0 | 0 | 0 | 59091 |
| 107 | 8.8. Mobibrasil Transp Urbano Ltda. | 0 | 0 | 0 | 0 | 89956.67 | 0 | 0 | 0 | 0 | 89956.67 |
| 108 | 8.9. Viação Cidade Dutra Ltda. | 0 | 0 | 0 | 0 | 154901.56 | 0 | 0 | 0 | 0 | 154901.56 |
| 109 | 8.10. VIP - Transportes Urbanos Ltda. | 0 | 0 | 0 | 0 | 0 | 104803.28 | 0 | 0 | 0 | 104803.28 |
| 110 | 8.11. Viação Campo Belo Ltda. | 0 | 0 | 0 | 0 | 0 | 15676.03 | 0 | 0 | 0 | 15676.03 |
| 111 | 8.12. Transkuba Transportes Gerais Ltda. | 0 | 0 | 0 | 0 | 0 | 71350.73 | 0 | 0 | 0 | 71350.73 |
| 112 | 8.13. Viação Gatusa Transportes Urb. Ltda. | 0 | 0 | 0 | 0 | 0 | 57481.72 | 0 | 0 | 0 | 57481.72 |
| 113 | 8.14. Consórcio Sete | 0 | 0 | 0 | 0 | 0 | 169501.04 | 0 | 0 | 0 | 169501.04 |
| 114 | 8.15. Viação Gato Preto Ltda. | 0 | 0 | 0 | 0 | 0 | 0 | 61751.09 | 0 | 0 | 61751.09 |
| 115 | 8.16. Transpass Transp. de Pass. Ltda | 0 | 0 | 0 | 0 | 0 | 0 | 108733.74 | 0 | 0 | 108733.74 |
| 116 | 8.17. Ambiental Transportes Urbanos S.A. | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 4717.97 | 0 | 4717.97 |
| 117 | 8.18. Express Transportes Urbanos Ltda | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 17758.23 | 17758.23 |
Note que contrário a tabela de concessão, a tabela de totais aqui e também na fonte não contém os valores finais (!) e portanto não podemos mais confiar no restante da análise nesta coluna.
kable(companies.permissao)| Empresa | Consórcio Transcooper Fênix | Consórcio Transcooper Fênix | Consórcio Aliança Paulistana | Transcooper | Consórcio Aliança Cooperpeople | Consórcio Auhto Pam | Consórcio Auhto Pam | Consórcio Unicoopers Cooperalfa | |
|---|---|---|---|---|---|---|---|---|---|
| 56 | 9.1. Fênix | 22551.74 | 15334.86 | 0 | 0 | 0 | 0 | 0 | 0 |
| 57 | 9.2. Transcooper | 103497.03 | 55662.42 | 0 | 77295.31 | 0 | 0 | 0 | 0 |
| 58 | 9.3. Paulistana | 0 | 0 | 52602.17 | 0 | 0 | 0 | 0 | 0 |
| 59 | 9.4. Paulistana I | 0 | 0 | 60637.21 | 0 | 0 | 0 | 0 | 0 |
| 60 | 9.5. Paulistana II | 0 | 0 | 15849.7 | 0 | 0 | 0 | 0 | 0 |
| 61 | 9.6. Nova Aliança | 0 | 0 | 9819.27 | 0 | 10318.72 | 0 | 0 | 0 |
| 62 | 9.7. Transcooper II | 0 | 0 | 0 | 44422.09 | 0 | 0 | 0 | 0 |
| 63 | 9.8. Transcooper III | 0 | 0 | 0 | 38964.26 | 0 | 0 | 0 | 0 |
| 64 | 9.9. Transcooper IV | 0 | 0 | 0 | 7786.89 | 0 | 0 | 0 | 0 |
| 65 | 9.10. Coopertranse | 0 | 0 | 0 | 0 | 74820.83 | 0 | 0 | 0 |
| 66 | 9.11. Cooperpam | 0 | 0 | 0 | 0 | 0 | 138098.75 | 151770.7 | 0 |
| 67 | 9.12. Cooperlider | 0 | 0 | 0 | 0 | 0 | 81576.35 | 0 | 0 |
| 68 | 9.13. Cooperalfa | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 25478.52 |
| 69 | 9.14. Unicoopers | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 53821.91 |
| 70 | 9.15. Parcela de remuneração repassada diretamente ao cooperado. | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 |
Como esta tabela é grande, então apenas as primeiras linhas serão exibidas. De imediato, podemos observar que o nome das empresas não são exatamente iguais aos das tabelas de demonstrativo por concessão e permissão. Esta pequena diferença torna a análise muito mais complicada ao cruzar as tabelas, pois será necessário usar métricas de similaridade ou alguma heuristica para saber que dois nomes diferentes nas duas empresas são similares.
kable(head(passageiro.table))| DATA | TIPO | AREA | EMPRESA | LINHA | PASSAGEIROS.PAGANTES.EM.DINHEIRO…A. | PASSAGEIROS.PAGANTES.BILHETE.ÚNICO.COMUM…B. | PASSAGEIROS.PAGANTES.BILHETE.ÚNICO.ESTUDANTE…C.. | PASSAGEIROS.PAGANTES.BILHETE.ÚNICO.VALE.TRANSPORTE…D. | PASSAGEIROS.PAGANTES.INTEGRAÇÕES.METRÔ.E.CPTM…E. | PASSAGEIROS.PAGANTES…F…..A…B…C…D…E. | PASSAGEIROS.INTEGRAÇÕES.ÔNIBUS….ÔNIBUS…G. | PASSAGEIROS.COM.GRATUIDADE…H. | TOTAL.PASSAGEIROS.TRANSPORTADOS…I…..F…G…H. | NA. |
|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2014-01-01 | CONCESSAO | AREA 1 | GATO PRETO | 800010 - TERM LAPA/PCA RAMOS | 195 | 202 | 15 | 189 | 73 | 674 | 673 | 215 | 1562 | NA |
| 2014-01-01 | CONCESSAO | AREA 1 | GATO PRETO | 853810 - VILA IARA/PAISSANDU | 7 | 4 | 0 | 6 | 0 | 17 | 13 | 3 | 33 | NA |
| 2014-01-01 | CONCESSAO | AREA 1 | GATO PRETO | 854210 - BRASILANDIA/PCA DO CORREIO | 424 | 439 | 42 | 390 | 52 | 1347 | 621 | 335 | 2303 | NA |
| 2014-01-01 | CONCESSAO | AREA 1 | GATO PRETO | 854510 - PENTEADO/METRO BARRA FUNDA | 143 | 138 | 25 | 149 | 101 | 556 | 273 | 123 | 952 | NA |
| 2014-01-01 | CONCESSAO | AREA 1 | GATO PRETO | 901410 - MORRO GRANDE/TERMINAL LAPA | 169 | 238 | 21 | 176 | 115 | 719 | 371 | 189 | 1279 | NA |
| 2014-01-01 | CONCESSAO | AREA 1 | GATO PRETO | 916210 - JD.ALMANARA/RIO BRANCO | 32 | 54 | 4 | 21 | 0 | 111 | 60 | 45 | 216 | NA |
Uma métrica de similaridade é a de “Distancia de Edição”. Basicamente todos os caracteres de duas strings são comparados conforme sua ordem no alfabeto para calcular a sua proximidade. Usando isso para toda a string, podemos tentar cruzar as tabelas. Antes disso, no entanto, precisamos pre-processar as strings para simplificar o processo de comparação.
Vamos começar definindo uma função que substitui letras que contém acentos por sua versão sem acentos.
#Source: http://pt.stackoverflow.com/questions/46473/remover-acentos
rm_accent <- function(str,pattern="all") {
# Rotinas e funções úteis V 1.0
# rm.accent - REMOVE ACENTOS DE PALAVRAS
# Função que tira todos os acentos e pontuações de um vetor de strings.
# Parâmetros:
# str - vetor de strings que terão seus acentos retirados.
# patterns - vetor de strings com um ou mais elementos indicando quais acentos deverão ser retirados.
# Para indicar quais acentos deverão ser retirados, um vetor com os símbolos deverão ser passados.
# Exemplo: pattern = c("´", "^") retirará os acentos agudos e circunflexos apenas.
# Outras palavras aceitas: "all" (retira todos os acentos, que são "´", "`", "^", "~", "¨", "ç")
if(!is.character(str))
str <- as.character(str)
pattern <- unique(pattern)
if(any(pattern=="Ç"))
pattern[pattern=="Ç"] <- "ç"
symbols <- c(
acute = "áéíóúÁÉÍÓÚýÝ",
grave = "àèìòùÀÈÌÒÙ",
circunflex = "âêîôûÂÊÎÔÛ",
tilde = "ãõÃÕñÑ",
umlaut = "äëïöüÄËÏÖÜÿ",
cedil = "çÇ"
)
nudeSymbols <- c(
acute = "aeiouAEIOUyY",
grave = "aeiouAEIOU",
circunflex = "aeiouAEIOU",
tilde = "aoAOnN",
umlaut = "aeiouAEIOUy",
cedil = "cC"
)
accentTypes <- c("´","`","^","~","¨","ç")
if(any(c("all","al","a","todos","t","to","tod","todo")%in%pattern)) # opcao retirar todos
return(chartr(paste(symbols, collapse=""), paste(nudeSymbols, collapse=""), str))
for(i in which(accentTypes%in%pattern))
str <- chartr(symbols[i],nudeSymbols[i], str)
return(str)
}Utilizamos essa função a seguir, além também de remover os códigos de cada empresa que aparecem nos demonstrativos, uma vez que calcular a sua distância poderia gerar errors na comparação.
#Remove codigos e transforma em caixa baixa
companies.concessao$Empresa <- lapply(strsplit(as.character(companies.concessao$Empresa)," "),"[",-1)
companies.concessao$Empresa <- tolower(sapply(companies.concessao$Empresa,function(x) paste(x,collapse=' ')))
companies.concessao$Empresa <- rm_accent(companies.concessao$Empresa)
#Remove codigos e transforma em caixa baixa
companies.permissao$Empresa <- lapply(strsplit(as.character(companies.permissao$Empresa)," "),"[",-1)
companies.permissao$Empresa <- tolower(sapply(companies.permissao$Empresa,function(x) paste(x,collapse=' ')))
companies.permissao$Empresa <- rm_accent(companies.permissao$Empresa)
#Nao posusi codigos, apenas coloca em caixa baixa e remove coluna extra gerada por erro de formatacao.
passageiro.table$EMPRESA <- tolower(passageiro.table$EMPRESA)
passageiro.table <- passageiro.table[,-ncol(passageiro.table)]Por fim, se podemos reduzir o número de palavras que iremos comparar para encontrar a mesma empresa em outra tabela, reduzimos também a chance de mapear para nome de empresas diferentes. Neste caso, na tabela de contagem de passageiros, sabemos que as empresas também são divididas por concessão e permissão, então podemos separar os dois grupos antes de compara-las, reduzindo assim o número de possibilidades.
#Separa passageiros de empresas por concessao e por permissao
is.concessao <- ifelse(passageiro.table$TIPO=="CONCESSAO",TRUE,FALSE)
passageiro.concessao <- passageiro.table[is.concessao,]
passageiro.permissao <- passageiro.table[!is.concessao,]Agora que temos os dois grupos, vamos tentar o cruzamento dos nomes nas duas tabelas para concessão e observar se a metrica é viável ou não para o restante da analise.
library(RecordLinkage)
#See also http://www.markvanderloo.eu/yaRb/2013/09/07/a-bit-of-benchmarking-with-string-distances/
similarity.join.aux <- function(string,lookup){
index <- which.max(levenshteinSim(string,lookup))
return(index)
}
similarity.join <- function(vector1,vector2){
indexes <- sapply(vector1,similarity.join.aux,vector2)
df <- data.frame(vector1,vector2[indexes])
return(df)
}
df <- similarity.join(passageiro.concessao$EMPRESA,companies.concessao$Empresa)
colnames(df) <- c("tabela.passageiros","tabela.concessao")
#Para inspeção, basta observar apenas as linhas da tabela não duplicadas
kable(df[!duplicated(df), ])| tabela.passageiros | tabela.concessao | |
|---|---|---|
| 1 | gato preto | viacao gato preto ltda. |
| 10 | santa brigida | viacao santa brigida ltda. |
| 66 | sambaiba | sambaiba transportes urbanos ltda. |
| 163 | expandir | express transportes urbanos ltda |
| 170 | vip ii | viacao santa brigida ltda. |
| 256 | ambiental | ambiental transportes urbanos s.a. |
| 268 | novo horizonte | consorcio sete |
| 300 | via sul | viacao cidade dutra ltda. |
| 375 | cidade dutra | viacao cidade dutra ltda. |
| 390 | mobibrasil | mobibrasil transp urbano ltda. |
| 410 | tupi | transkuba transportes gerais ltda. |
| 435 | campo belo | viacao campo belo ltda. |
| 478 | gatusa | viacao gato preto ltda. |
| 485 | transkuba | mobibrasil transp urbano ltda. |
| 499 | vip | consorcio plus |
| 536 | transpass | transpass transp. de pass. ltda |
Infelizmente, podemos notar que algumas empresas não tiveram o mapeamento correto. Uma outra heuristica que podemos tentar utilizar é notar que o nome das empresas na tabela de passsageiros parece sempre estar contido nos seus respectivos nomes nas tabelas de demonstrativos. De fato, talvez a ideia de renomear as empresas na outra tabela tenha sido de manter apenas o que identifica unicamente a empresa em ambas as tabelas. (e.g. Ltda. ou viação são comuns a mais do nome de uma empresa).
Podemos usar isso como heuristica, e usar a primeira palavra do nome da empresa da tabela de passageiros para tentar cruzar com as de demonstrativos. Redefinimos portanto a função de comparação não mais usando a metrica de distancia de edição, mas para apenas que encontre a primeira ocorrencia da primeira palavra da empresa da tabela de passageiros na respectiva tabela de demonstrativos.
similarity.join.aux <- function(string,lookup){
string <- unlist(strsplit(string," "))[1]
#index <- grepl(string,lookup) Grepl confundiria 'via' com 'viacao' uma vez que nao leva em conta espacos.
#As 4 linhas seguintes separam por espaco e realizam a comparacao de forma correta.
list <- strsplit(lookup," ")
position <- sapply(list,function(x) which(x== string))
position <- sapply(position, function(x) length(x) > 0)
index <- which.max(position)
return(index)
}
empresas <- array(NA,(length(companies.concessao$Empresa)+1))
empresas[2:length(empresas)] <- companies.concessao$Empresa
df <- similarity.join(passageiro.concessao$EMPRESA,empresas)
colnames(df) <- c("tabela.passageiros","tabela.concessao")
#Para inspeção, basta observar apenas as linhas da tabela não duplicadas
kable(df[!duplicated(df), ])| tabela.passageiros | tabela.concessao | |
|---|---|---|
| 1 | gato preto | viacao gato preto ltda. |
| 10 | santa brigida | viacao santa brigida ltda. |
| 66 | sambaiba | sambaiba transportes urbanos ltda. |
| 163 | expandir | NA |
| 170 | vip ii | vip - transportes urbanos ltda. |
| 256 | ambiental | ambiental transportes urbanos s.a. |
| 268 | novo horizonte | NA |
| 300 | via sul | via sul transportes urbanos ltda. |
| 375 | cidade dutra | viacao cidade dutra ltda. |
| 390 | mobibrasil | mobibrasil transp urbano ltda. |
| 410 | tupi | tupi transportes urbanos piratininga ltda. |
| 435 | campo belo | viacao campo belo ltda. |
| 478 | gatusa | viacao gatusa transportes urb. ltda. |
| 485 | transkuba | transkuba transportes gerais ltda. |
| 499 | vip | vip - transportes urbanos ltda. |
| 536 | transpass | transpass transp. de pass. ltda |
Notamos que todos os mapeamentos agora são corretos, no entanto a tabela esta incompleta. Isso é preferível, uma vez que é mais facil identificar na tabela mapeamentos incompletos do que erroneos. Resta então observar o que levou a falta de mapeamento na tabela para as empresas de nome expandir e novo horizonte. Se inspecionarmos a tabela de Demonstrativo Detalhado Concessão (1/1/2014), isso fica claro:
A empresa expandir não é citada em nenhum momento no documento. A única forma de identificar o nome é observando neste caso que na tabela de Passageiros Transportados (1/1/2014) ela pertence a area 3, e observando-se as colunas da tabela de Demonstrativo Detalhado Concessão (1/1/2014) a única empresa com esta area é a Consórcio Plus. Infelizmente, como os consórcios podem incluir mais de uma empresa, como é o caso do Consórcio Unisul, seria arriscado criar uma heuristica de mapeamento utilizando área (além da separação em linhas dos consórcios e das areas que apresentaria dificuldades na aplicação do script em outras tabelas). Neste caso, somente por análise manual poderíamos identificar esta empresa.
O caso da empresa nova horizonte é ainda mais bizarro. Realizando o mesmo procedimento, notamos que ela pertence a area 4, e que a mesma nem sequer consta (!!!) no detalhamento de pagamentos.
Como observamos que o cruzamento por heuristica não gerou mapeamentos erroneos, mas somente incompletos, utilizamos o mesmo para cruzar a tabela de passageiros com a de permissão.
empresas <- array(NA,(length(companies.permissao$Empresa)+1))
empresas[2:length(empresas)] <- companies.permissao$Empresa
df <- similarity.join(passageiro.permissao$EMPRESA,empresas)
colnames(df) <- c("tabela.passageiros","tabela.permissao")
#Para inspeção, basta observar apenas as linhas da tabela não duplicadas
kable(df[!duplicated(df), ])| tabela.passageiros | tabela.permissao | |
|---|---|---|
| 1 | fenix | fenix |
| 9 | transcooper | transcooper |
| 75 | nova alianca | nova alianca |
| 78 | paulistana | paulistana |
| 105 | paulistana i | paulistana |
| 129 | paulistana ii | paulistana |
| 178 | transcooper ii | transcooper |
| 200 | transcooper iii | transcooper |
| 213 | transcooper iv | transcooper |
| 218 | coopertranse | coopertranse |
| 254 | cooperlider | cooperlider |
| 285 | cooperpam | cooperpam |
| 391 | cooperalfa | cooperalfa |
| 400 | uniccoopers | NA |
| 416 | unicoopers | unicoopers |
No caso do cruzamento para Demonstrativo Detalhado Permissão (1/1/2014), notamos somente uma empresa onde o mapeamento não foi possível, devido a um erro de digitação com um ‘c’ adicional uniccoopers. No entanto, observamos um novo problema com a heuristica: Existem empresas de mesmo nome seguidas de numeração. Para lidar com o problema, extendemos a função de comparação para comparar não somente uma palavra, mas todas.
similarity.join.aux <- function(string,lookup){
find.word <- function(string,lookup){
#index <- grepl(string,lookup) Grepl confundiria 'via' com 'viacao' uma vez que nao leva em conta espacos.
#As 4 linhas seguintes separam por espaco e realizam a comparacao de forma correta.
list <- strsplit(lookup," ")
position <- sapply(list,function(x) which(x== string))
position <- sapply(position, function(x) length(x) > 0)
return(as.integer(position))
}
string <- unlist(strsplit(string," "))
#Criaremos um vetor de score para cada posicao de empresa na outra tabela. Por exemplo
#"transcooper ii" serao duas palavras. "transcooper" sera identificada em "transcooper ii"
#"transcooper iii" e "transcooper iv" ; "ii" por sua vez pode ser identificado em "transcooper ii"
#e em "paulistana ii". Como o score de "transcooper ii" sera maior somando-se as buscas das palavras
#"transcooper" e "ii", o mapeamento sera feito corretamente para "transcooper ii"!
score <- array(0,length(string[1]))
for(word in string){
score <- score + find.word(word,lookup)
}
index <- which.max(score)
return(index)
}
df <- similarity.join(passageiro.permissao$EMPRESA,empresas)
colnames(df) <- c("tabela.passageiros","tabela.permissao")
#Para inspeção, basta observar apenas as linhas da tabela não duplicadas
kable(df[!duplicated(df), ])| tabela.passageiros | tabela.permissao | |
|---|---|---|
| 1 | fenix | fenix |
| 9 | transcooper | transcooper |
| 75 | nova alianca | nova alianca |
| 78 | paulistana | paulistana |
| 105 | paulistana i | paulistana i |
| 129 | paulistana ii | paulistana ii |
| 178 | transcooper ii | transcooper ii |
| 200 | transcooper iii | transcooper iii |
| 213 | transcooper iv | transcooper iv |
| 218 | coopertranse | coopertranse |
| 254 | cooperlider | cooperlider |
| 285 | cooperpam | cooperpam |
| 391 | cooperalfa | cooperalfa |
| 400 | uniccoopers | NA |
| 416 | unicoopers | unicoopers |
Com a nova heuristica usando multiplas palavras, podemos observar que não mais ocorrem mapeamentos incorretos.
Como as duas tabelas não contem necessariamente o total, calculamos a coluna total a partir dos valores individuais de cada empresa.
#Concessao
custos <- companies.concessao[,2:(ncol(companies.concessao))]
custos <- lapply(custos,as.character)
custos <- data.frame(lapply(custos,as.numeric))
companies.concessao$TOTAL <- rowSums(custos[,1:(ncol(custos)-1)],na.rm=TRUE)
#Permissao
custos <- companies.permissao[,2:(ncol(companies.permissao))]
custos <- lapply(custos,as.character)
custos <- data.frame(lapply(custos,as.numeric))
companies.permissao$TOTAL <- rowSums(custos[,1:(ncol(custos)-1)],na.rm=TRUE)Por fim geramos a tabela inicialmente desejada que demonstra a remuneração da empresa em 1/1/2014 e o seu número de passageiros por tipo de passageiros. A tabela a seguir mostra o resultado do cruzamento.
#Cruzamento Permissão
empresas <- array(NA,(length(companies.permissao$Empresa)+1))
empresas[2:length(empresas)] <- companies.permissao$Empresa
cruzamento.permissao <- similarity.join(passageiro.permissao$EMPRESA,empresas)
#Cruzamento Concessão
empresas <- array(NA,(length(companies.concessao$Empresa)+1))
empresas[2:length(empresas)] <- companies.concessao$Empresa
cruzamento.concessao <- similarity.join(passageiro.concessao$EMPRESA,empresas)
#Merge Row-wise
cruzamento <- rbind(cruzamento.concessao,cruzamento.permissao)
cruzamento <- cruzamento[!duplicated(cruzamento), ]
colnames(cruzamento) <- c("passageiros","demonstrativos")
#Merge Row-Wise
custos <- rbind(companies.permissao[,c("Empresa","TOTAL")],companies.concessao[,c("Empresa","TOTAL")])
#Inner join (NAs serao desconsiderados)
df <- merge(cruzamento,passageiro.concessao,by.x="passageiros",by.y="EMPRESA")
df <- merge(df,custos,by.x="demonstrativos",by.y="Empresa",all.x=TRUE)
kable(head(df))| demonstrativos | passageiros | DATA | TIPO | AREA | LINHA | PASSAGEIROS.PAGANTES.EM.DINHEIRO…A. | PASSAGEIROS.PAGANTES.BILHETE.ÚNICO.COMUM…B. | PASSAGEIROS.PAGANTES.BILHETE.ÚNICO.ESTUDANTE…C.. | PASSAGEIROS.PAGANTES.BILHETE.ÚNICO.VALE.TRANSPORTE…D. | PASSAGEIROS.PAGANTES.INTEGRAÇÕES.METRÔ.E.CPTM…E. | PASSAGEIROS.PAGANTES…F…..A…B…C…D…E. | PASSAGEIROS.INTEGRAÇÕES.ÔNIBUS….ÔNIBUS…G. | PASSAGEIROS.COM.GRATUIDADE…H. | TOTAL.PASSAGEIROS.TRANSPORTADOS…I…..F…G…H. | TOTAL |
|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
| ambiental transportes urbanos s.a. | ambiental | 2014-01-01 | CONCESSAO | AREA 4 | 316010 - TERM.V.PRUDENTE/ TERM D PEDRO | 104 | 100 | 11 | 74 | 18 | 307 | 231 | 60 | 598 | 4717.97 |
| ambiental transportes urbanos s.a. | ambiental | 2014-01-01 | CONCESSAO | AREA 4 | 411310 - GENTIL DE MOURA/PCA REPUBLICA | 441 | 457 | 45 | 377 | 242 | 1562 | 552 | 294 | 2408 | 4717.97 |
| ambiental transportes urbanos s.a. | ambiental | 2014-01-01 | CONCESSAO | AREA 4 | 200210 - TERM P D PEDRO II/TERM BANDEIR | 14 | 98 | 4 | 58 | 13 | 187 | 294 | 110 | 591 | 4717.97 |
| ambiental transportes urbanos s.a. | ambiental | 2014-01-01 | CONCESSAO | AREA 4 | 210010 - TERM V CARRAO/PCA DA SE CIRC | 226 | 278 | 21 | 163 | 27 | 715 | 427 | 219 | 1361 | 4717.97 |
| ambiental transportes urbanos s.a. | ambiental | 2014-01-01 | CONCESSAO | AREA 4 | 303210 - TERM VILA CARRAO/CIRCULAR | 46 | 96 | 8 | 52 | 0 | 202 | 153 | 72 | 427 | 4717.97 |
| ambiental transportes urbanos s.a. | ambiental | 2014-01-01 | CONCESSAO | AREA 4 | 313910 - JD VILA FORMOSA/PCA CLOVIS | 42 | 55 | 5 | 31 | 2 | 135 | 80 | 56 | 271 | 4717.97 |
Note no entanto que o custo da remuneração sendo por empresa é repetido para cada linha. Nos resta remover a coluna de linhas e somar o total de passageiros em todas as linhas para a empresa.
df <- df[,c(-2,-3,-4,-6)]
df <- aggregate(. ~ demonstrativos + AREA,df,sum)
df <- df[with(df, order(-TOTAL)), ]
colnames(df) <- c("EMPRESAS",
"AREA",
"PASSAGEIROS PAGANTES EM DINHEIRO (A)",
"PASSAGEIROS PAGANTES BILHETE UNICO COMUM (B)",
"PASSAGEIROS PAGANTES BILHETE UNICO ESTUDANTE (C)",
"PASSAGEIROS PAGANTES BILHETE UNICO VALE TRANSPORTE (D)",
"PASSAGEIROS PAGANTES INTEGRAÇÕES METRO E CPTM (E)",
"PASSAGEIROS PAGANTES (F) = (A + B + C + D + E)",
"PASSAGEIROS INTEGRAÇÕES ONIBUS -> ONIBUS (G)",
"PASSAGEIROS COM GRATUIDADE (H)",
"TOTAL PASSAGEIROS TRANSPORTADOS (I) = (F + G + H)",
"R$ TOTAL")
kable(df)| EMPRESAS | AREA | PASSAGEIROS PAGANTES EM DINHEIRO (A) | PASSAGEIROS PAGANTES BILHETE UNICO COMUM (B) | PASSAGEIROS PAGANTES BILHETE UNICO ESTUDANTE (C) | PASSAGEIROS PAGANTES BILHETE UNICO VALE TRANSPORTE (D) | PASSAGEIROS PAGANTES INTEGRAÇÕES METRO E CPTM (E) | PASSAGEIROS PAGANTES (F) = (A + B + C + D + E) | PASSAGEIROS INTEGRAÇÕES ONIBUS -> ONIBUS (G) | PASSAGEIROS COM GRATUIDADE (H) | TOTAL PASSAGEIROS TRANSPORTADOS (I) = (F + G + H) | R$ TOTAL | |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 3 | sambaiba transportes urbanos ltda. | AREA 2 | 23997 | 25282 | 2885 | 19873 | 10120 | 82157 | 36346 | 12751 | 131254 | 27916541.80 |
| 6 | via sul transportes urbanos ltda. | AREA 5 | 12698 | 15104 | 1519 | 11450 | 6102 | 46873 | 22945 | 7923 | 77741 | 12777367.50 |
| 4 | vip - transportes urbanos ltda. | AREA 3 | 53752 | 58670 | 5836 | 46446 | 13382 | 178086 | 83348 | 34866 | 296300 | 12709103.22 |
| 2 | viacao santa brigida ltda. | AREA 1 | 13865 | 14702 | 1704 | 13757 | 4516 | 48544 | 24259 | 6870 | 79673 | 8644610.80 |
| 15 | transpass transp. de pass. ltda | AREA 8 | 9009 | 8787 | 1109 | 9947 | 4453 | 33305 | 14352 | 3134 | 50791 | 3588213.42 |
| 14 | vip - transportes urbanos ltda. | AREA 7 | 14210 | 28780 | 2682 | 27516 | 6760 | 79948 | 58450 | 8626 | 147024 | 2955605.40 |
| 9 | viacao cidade dutra ltda. | AREA 6 | 7469 | 13266 | 1223 | 10480 | 2906 | 35344 | 32420 | 5421 | 73185 | 2323523.40 |
| 7 | mobibrasil transp urbano ltda. | AREA 6 | 6269 | 8117 | 792 | 7068 | 1455 | 23701 | 13357 | 3977 | 41035 | 1799133.40 |
| 10 | vip - transportes urbanos ltda. | AREA 6 | 5094 | 6260 | 718 | 7346 | 1406 | 20824 | 11274 | 3060 | 35158 | 1477802.70 |
| 16 | viacao gato preto ltda. | AREA 8 | 4368 | 5818 | 566 | 6424 | 2092 | 19268 | 13908 | 3056 | 36232 | 1443489.38 |
| 11 | transkuba transportes gerais ltda. | AREA 7 | 5181 | 7202 | 627 | 7605 | 1572 | 22187 | 13633 | 2253 | 38073 | 998910.22 |
| 8 | tupi transportes urbanos piratininga ltda. | AREA 6 | 5525 | 6131 | 702 | 6150 | 1903 | 20411 | 9009 | 2769 | 32189 | 886365.00 |
| 1 | viacao gato preto ltda. | AREA 1 | 3526 | 4098 | 414 | 3470 | 2104 | 13612 | 8724 | 2732 | 25068 | 764200.26 |
| 12 | viacao campo belo ltda. | AREA 7 | 9161 | 16375 | 1429 | 16923 | 4898 | 48786 | 39106 | 5689 | 93581 | 674069.29 |
| 13 | viacao gatusa transportes urb. ltda. | AREA 7 | 1627 | 2831 | 213 | 3684 | 949 | 9304 | 8011 | 1093 | 18408 | 402372.04 |
| 5 | ambiental transportes urbanos s.a. | AREA 4 | 2490 | 2433 | 204 | 1616 | 400 | 7143 | 3982 | 1843 | 12968 | 56615.64 |