Aluguel de bicicleta nos Estados Unidos
Rodolfo Rissetto Terra - Data Scientist
11 - 11 - 2020
1 Coleta dos Dados
Aqui segue a coleta de dados do data set.
Podemos observar a tabela a seguir:
Na primeira linha: a dimensão do conjunto de dados, quantidades de observações (linhas) e quantidade de colunas, ou variáveis. Na demais linhas : a primeira coluna com os demes de cada viriável, o tipo do caracter da variável, se é numério, númeiro inteiro, string (caracteres) e a demonstração de cada variável dentro do conjunto de dados na terceira coluna.
# Loading Data
bikes <- read.csv('bikes.csv', sep = ',', header = T, stringsAsFactors = FALSE)
str(bikes)## 'data.frame': 17379 obs. of 17 variables:
## $ instant : int 1 2 3 4 5 6 7 8 9 10 ...
## $ dteday : chr "2011-01-01" "2011-01-01" "2011-01-01" "2011-01-01" ...
## $ season : int 1 1 1 1 1 1 1 1 1 1 ...
## $ yr : int 0 0 0 0 0 0 0 0 0 0 ...
## $ mnth : int 1 1 1 1 1 1 1 1 1 1 ...
## $ hr : int 0 1 2 3 4 5 6 7 8 9 ...
## $ holiday : int 0 0 0 0 0 0 0 0 0 0 ...
## $ weekday : int 6 6 6 6 6 6 6 6 6 6 ...
## $ workingday: int 0 0 0 0 0 0 0 0 0 0 ...
## $ weathersit: int 1 1 1 1 1 2 1 1 1 1 ...
## $ temp : num 0.24 0.22 0.22 0.24 0.24 0.24 0.22 0.2 0.24 0.32 ...
## $ atemp : num 0.288 0.273 0.273 0.288 0.288 ...
## $ hum : num 0.81 0.8 0.8 0.75 0.75 0.75 0.8 0.86 0.75 0.76 ...
## $ windspeed : num 0 0 0 0 0 0.0896 0 0 0 0 ...
## $ casual : int 3 8 5 3 0 0 2 1 1 8 ...
## $ registered: int 13 32 27 10 1 1 0 2 7 6 ...
## $ cnt : int 16 40 32 13 1 1 2 3 8 14 ...Podemos também observar as cinco primeiras linhas de nosso conjunto de dados, usando a função “head(bikes)” e as cinco últimas linhas do nosso conjunto de dados com a utilização da função “tail(bikes)”.
rbind(head(bikes), tail(bikes))Segue o quadro abaixo com todas as colunas e a quantidade de valores minssing em nosso conjuntos de dados, ou seja, valores que não estão preeenchido com informações, valores faltantes.
Ao analisar o conjunto de dados, podemos perceber que temos quase 100% das informações preenchida, tendo soment dois campos da coluna “dteday” com falta de informação, denvendo ser aterada futuramente para a criação do modelo.
rbind(head(bikes), tail(bikes))char.toPOSIXct <- function(inFrame) {
as.POSIXct(strptime(
paste(inFrame$dteday, " ",
as.character(inFrame$hr),
":00:00",
sep = ""),
"%Y-%m-%d %H:%M:%S")) }
bikes$dteday <- char.toPOSIXct(bikes)
sapply(bikes, function(x) sum(is.na(x)))## instant dteday season yr mnth hr holiday
## 0 2 0 0 0 0 0
## weekday workingday weathersit temp atemp hum windspeed
## 0 0 0 0 0 0 0
## casual registered cnt
## 0 0 0Como o objetivo do problema de negócio é a análise de demanda por biciletas, será realizar o primeiro filtro em nosso conjunto de dados para observarmos somentos os dias em que existiu a quantidade demandada de bicicleta acima de 100 unidades.
Ao realizar a filto somente acima de 100 unidades diárias, reduzimos o nosso conjunto de dados para 10.342 linhas
require(dplyr)
bikes <- bikes %>% filter(cnt >100)
dim(bikes)## [1] 10344 172 Transformação de Carga
Em primeiro momento separaremos, em conformidade com o objetivo de negócio, baseando no item “1.2. Informações do conjuntos de dados” e “1.3 Informações sobre os atributos” uma seleção de variáveis considerando as mais relevantes para o modelo.
Na transformação de carga iremos realizar a normalização das variáveis numéricas, transformando toda as coluna em uma mesma escala, para que possamos na hora de criar o modelo preditivo, possamos observar um nível de acúrária melhor.
Iremos também criar novas variáveis, para melhor entendimento do conjuntos de dados, afim de evitar possíveis erros em nosso conjuntos. Criaremos a coluna (“isWorking” - dias úteis, “monthCount” - mês e “dayWeek” - dia de semana).
cols <- c("dteday", "mnth", "hr", "holiday",
"workingday", "weathersit", "temp",
"hum", "windspeed", "cnt")
# Criando um subset dos dados
bikes <- bikes[,cols]
# Transformar o objeto de data
bikes$dteday <- char.toPOSIXct(bikes)
# Esta linha acima gera dois valores NA
# Esta linha abaixo corrige
bikes <- na.omit(bikes)
# Normalizar as variaveis preditoras numericas
cols <- c('temp', 'hum', 'windspeed')
bikes[,cols] <- scale(bikes[,cols])
str(bikes)## 'data.frame': 10342 obs. of 10 variables:
## $ dteday : POSIXct, format: "2011-01-01 14:00:00" "2011-01-01 15:00:00" ...
## $ mnth : int 1 1 1 1 1 1 1 1 1 1 ...
## $ hr : int 14 15 8 17 18 19 8 17 18 19 ...
## $ holiday : int 0 0 0 0 0 0 0 0 0 0 ...
## $ workingday: int 0 0 1 1 1 1 1 1 1 1 ...
## $ weathersit: int 2 2 1 1 1 1 1 1 1 1 ...
## $ temp : num -0.542 -0.653 -2.317 -1.762 -1.762 ...
## $ hum : num 0.783 1.056 -0.417 -1.509 -1.399 ...
## $ windspeed : num 0.682 0.805 0.682 0.193 -0.787 ...
## $ cnt : int 106 110 154 157 157 110 179 212 182 112 ...
## - attr(*, "na.action")= 'omit' Named int [1:2] 3581 9289
## ..- attr(*, "names")= chr [1:2] "3581" "9289"rbind(head(bikes), tail(bikes))# Criar uma nova variável para indicar dia da semana (workday)
bikes$isWorking <- ifelse(bikes$workingday & !bikes$holiday, 1, 0)
# Adicionar uma coluna com a quantidade de meses, o que vai ajudar a criar o modelo
month.count <- function(inFrame){
Dteday <- strftime(inFrame$dteday, format = "%Y-%m-%dT%H:%M:%S")
yearCount <- as.numeric(unlist(lapply(strsplit(
Dteday, "-"),
function(x){x[1]}))) - 2011
inFrame$monthCount <- 12 * yearCount + inFrame$mnth
inFrame
}
bikes <- month.count(bikes)
# Criar um fator ordenado para o dia da semana, comecando por segunda-feira
bikes$dayWeek <- as.factor(weekdays(bikes$dteday))
head(bikes)Podemos observar que na tabela acima que na coluna “dayWeek” está recebendo os dias da semana: de segunda-feira à domingo.
A tabela abaixo a coluna “dayWeek” agora os dias da semana devem estar como valores numéricos.
bikes$dayWeek <- as.numeric(ordered(bikes$dayWeek,
levels = c("segunda-feira",
"terça-feira",
"quarta-feira",
"quinta-feira",
"sexta-feira",
"sábado",
"domingo")))
head(bikes)3 Engenharia de Atributos
Adiciona uma variável com valores únicos para o horário do dia em dias de semana e dias de fim de semana. Com isso diferenciamos as horas dos dias de semana, das horas em dias de fim de semana
bikes$workTime <- ifelse(bikes$isWorking, bikes$hr, bikes$hr + 24)
# Transforma os valores de hora na madrugada, quando a demanda por bibicletas é praticamente nula
bikes$xformHr <- ifelse(bikes$hr > 4, bikes$hr - 5, bikes$hr + 19)
# Adiciona uma variável com valores únicos para o horário do dia para dias de semana e dias de fim de semana
# Considerando horas da madrugada
bikes$xformWorkHr <- ifelse(bikes$isWorking, bikes$xformHr, bikes$xformHr + 24)
str(bikes)## 'data.frame': 10342 obs. of 16 variables:
## $ dteday : POSIXct, format: "2011-01-01 14:00:00" "2011-01-01 15:00:00" ...
## $ mnth : int 1 1 1 1 1 1 1 1 1 1 ...
## $ hr : int 14 15 8 17 18 19 8 17 18 19 ...
## $ holiday : int 0 0 0 0 0 0 0 0 0 0 ...
## $ workingday : int 0 0 1 1 1 1 1 1 1 1 ...
## $ weathersit : int 2 2 1 1 1 1 1 1 1 1 ...
## $ temp : num -0.542 -0.653 -2.317 -1.762 -1.762 ...
## $ hum : num 0.783 1.056 -0.417 -1.509 -1.399 ...
## $ windspeed : num 0.682 0.805 0.682 0.193 -0.787 ...
## $ cnt : int 106 110 154 157 157 110 179 212 182 112 ...
## $ isWorking : num 0 0 1 1 1 1 1 1 1 1 ...
## $ monthCount : num 1 1 1 1 1 1 1 1 1 1 ...
## $ dayWeek : num 6 6 1 1 1 1 2 2 2 2 ...
## $ workTime : num 38 39 8 17 18 19 8 17 18 19 ...
## $ xformHr : num 9 10 3 12 13 14 3 12 13 14 ...
## $ xformWorkHr: num 33 34 3 12 13 14 3 12 13 14 ...
## - attr(*, "na.action")= 'omit' Named int [1:2] 3581 9289
## ..- attr(*, "names")= chr [1:2] "3581" "9289"4 Análise de Correlação
Existe diversas técnicas para a análise de correlação entre as variáveis de nosso conjunto de dados. Em nosso modelo utilizaremos apenas duas:
Pearson - coeficiente usado para medir o grau de relacionamento entre duas variáveis com relação linear;
Spearman - teste não paramétrico, para medir o grau de relacionamento entre duas variaveis;
cols <- c("mnth", "hr", "holiday", "workingday",
"weathersit", "temp", "hum", "windspeed",
"isWorking", "monthCount", "dayWeek",
"workTime", "xformHr", "cnt")
# Vetor com os métodos de correlação
metodos <- c('pearson','spearman')
# Aplicando os métodos de correlação com a função cor()
cors <- lapply(metodos, function(method)
(cor(bikes[,cols], method = method)))
head(cors)## [[1]]
## mnth hr holiday workingday weathersit
## mnth 1.000000000 -0.0136042973 0.008793902 -0.0138388321 0.05840581
## hr -0.013604297 1.0000000000 -0.005520887 -0.0006323913 -0.06736674
## holiday 0.008793902 -0.0055208870 1.000000000 -0.2425512192 -0.01835272
## workingday -0.013838832 -0.0006323913 -0.242551219 1.0000000000 0.04953479
## weathersit 0.058405813 -0.0673667444 -0.018352723 0.0495347916 1.00000000
## temp 0.064922430 0.0980559021 0.008323454 -0.0107187615 -0.10799126
## hum 0.169468456 -0.1618604473 -0.009470555 0.0342820187 0.43078518
## windspeed -0.138354012 0.0407698801 0.009087200 -0.0117451965 -0.02761308
## isWorking -0.013838832 -0.0006323913 -0.242551219 1.0000000000 0.04953479
## monthCount 0.402902865 -0.0183907785 0.012936999 -0.0144820763 0.03331750
## dayWeek 0.008096668 0.0057470548 -0.168587689 -0.6999169949 -0.05072788
## workTime 0.006903870 0.4174590932 0.218103726 -0.9089595324 -0.07309621
## xformHr 0.006098419 0.8160565174 0.001099527 -0.1151723378 -0.07917747
## cnt 0.072404459 0.0504996750 -0.010775456 -0.0178389461 -0.11363010
## temp hum windspeed isWorking monthCount
## mnth 0.064922430 0.169468456 -0.1383540123 -0.0138388321 0.402902865
## hr 0.098055902 -0.161860447 0.0407698801 -0.0006323913 -0.018390779
## holiday 0.008323454 -0.009470555 0.0090871999 -0.2425512192 0.012936999
## workingday -0.010718762 0.034282019 -0.0117451965 1.0000000000 -0.014482076
## weathersit -0.107991263 0.430785180 -0.0276130822 0.0495347916 0.033317501
## temp 1.000000000 -0.099110979 -0.0262672773 -0.0107187615 -0.032336350
## hum -0.099110979 1.000000000 -0.2708755225 0.0342820187 0.019952516
## windspeed -0.026267277 -0.270875522 1.0000000000 -0.0117451965 -0.074350779
## isWorking -0.010718762 0.034282019 -0.0117451965 1.0000000000 -0.014482076
## monthCount -0.032336350 0.019952516 -0.0743507788 -0.0144820763 1.000000000
## dayWeek -0.003146259 -0.053534426 0.0054068644 -0.6999169949 0.011405683
## workTime 0.050618075 -0.098629032 0.0276691407 -0.9089595324 0.005492974
## xformHr 0.109501457 -0.111091068 -0.0006654943 -0.1151723378 0.018037934
## cnt 0.271030746 -0.173727633 0.0278603203 -0.0178389461 0.300181501
## dayWeek workTime xformHr cnt
## mnth 0.008096668 0.006903870 0.0060984187 0.07240446
## hr 0.005747055 0.417459093 0.8160565174 0.05049967
## holiday -0.168587689 0.218103726 0.0010995270 -0.01077546
## workingday -0.699916995 -0.908959532 -0.1151723378 -0.01783895
## weathersit -0.050727878 -0.073096210 -0.0791774726 -0.11363010
## temp -0.003146259 0.050618075 0.1095014572 0.27103075
## hum -0.053534426 -0.098629032 -0.1110910680 -0.17372763
## windspeed 0.005406864 0.027669141 -0.0006654943 0.02786032
## isWorking -0.699916995 -0.908959532 -0.1151723378 -0.01783895
## monthCount 0.011405683 0.005492974 0.0180379337 0.30018150
## dayWeek 1.000000000 0.638407560 0.0968783145 0.01648730
## workTime 0.638407560 1.000000000 0.4448578968 0.03726271
## xformHr 0.096878314 0.444857897 1.0000000000 -0.02437982
## cnt 0.016487299 0.037262706 -0.0243798215 1.00000000
##
## [[2]]
## mnth hr holiday workingday weathersit
## mnth 1.000000000 -0.009966956 1.068391e-02 -0.013761000 0.06713597
## hr -0.009966956 1.000000000 -4.810764e-03 -0.024589912 -0.08804987
## holiday 0.010683908 -0.004810764 1.000000e+00 -0.242551219 -0.01758894
## workingday -0.013761000 -0.024589912 -2.425512e-01 1.000000000 0.05360624
## weathersit 0.067135968 -0.088049869 -1.758894e-02 0.053606243 1.00000000
## temp 0.023197931 0.094622754 1.038633e-02 -0.007768081 -0.12267617
## hum 0.170176626 -0.143611637 -9.450112e-03 0.033250566 0.41196984
## windspeed -0.132505594 0.029645340 1.159437e-02 -0.014872236 -0.05001919
## isWorking -0.013761000 -0.024589912 -2.425512e-01 1.000000000 0.05360624
## monthCount 0.433614594 -0.011592106 1.275534e-02 -0.014963469 0.03978622
## dayWeek 0.007751764 0.024715511 -1.681113e-01 -0.698787618 -0.05490375
## workTime 0.005768616 0.611634311 1.875545e-01 -0.787363909 -0.10482421
## xformHr 0.003588295 0.906614222 -4.852017e-05 -0.104754247 -0.09344981
## cnt 0.070978505 0.033706352 -9.114978e-04 -0.039531007 -0.11356974
## temp hum windspeed isWorking monthCount
## mnth 0.023197931 0.170176626 -0.132505594 -0.013761000 0.433614594
## hr 0.094622754 -0.143611637 0.029645340 -0.024589912 -0.011592106
## holiday 0.010386327 -0.009450112 0.011594371 -0.242551219 0.012755335
## workingday -0.007768081 0.033250566 -0.014872236 1.000000000 -0.014963469
## weathersit -0.122676167 0.411969843 -0.050019188 0.053606243 0.039786217
## temp 1.000000000 -0.093830267 -0.008052581 -0.007768081 -0.049966065
## hum -0.093830267 1.000000000 -0.274872087 0.033250566 0.023745360
## windspeed -0.008052581 -0.274872087 1.000000000 -0.014872236 -0.080276591
## isWorking -0.007768081 0.033250566 -0.014872236 1.000000000 -0.014963469
## monthCount -0.049966065 0.023745360 -0.080276591 -0.014963469 1.000000000
## dayWeek -0.008090398 -0.055440865 0.008845523 -0.698787618 0.011940045
## workTime 0.065124023 -0.120032441 0.030861247 -0.787363909 0.008132094
## xformHr 0.099076182 -0.103655240 -0.001651065 -0.104754247 0.014612159
## cnt 0.296568467 -0.182872397 0.038725711 -0.039531007 0.281719259
## dayWeek workTime xformHr cnt
## mnth 0.007751764 0.005768616 3.588295e-03 0.0709785050
## hr 0.024715511 0.611634311 9.066142e-01 0.0337063517
## holiday -0.168111320 0.187554495 -4.852017e-05 -0.0009114978
## workingday -0.698787618 -0.787363909 -1.047542e-01 -0.0395310066
## weathersit -0.054903746 -0.104824215 -9.344981e-02 -0.1135697367
## temp -0.008090398 0.065124023 9.907618e-02 0.2965684666
## hum -0.055440865 -0.120032441 -1.036552e-01 -0.1828723968
## windspeed 0.008845523 0.030861247 -1.651065e-03 0.0387257114
## isWorking -0.698787618 -0.787363909 -1.047542e-01 -0.0395310066
## monthCount 0.011940045 0.008132094 1.461216e-02 0.2817192592
## dayWeek 1.000000000 0.555704931 8.814110e-02 0.0402850454
## workTime 0.555704931 1.000000000 6.468276e-01 0.0520637898
## xformHr 0.088141100 0.646827621 1.000000e+00 -0.0389455295
## cnt 0.040285045 0.052063790 -3.894553e-02 1.0000000000# Preprando o plot
require(lattice)
plot.cors <- function(x, labs){
diag(x) <- 0.0
plot( levelplot(x,
main = paste("Plot de Correlação utilizando o Método:", labs),
scales = list(x = list(rot = 90), cex = 1.0)) )
}
# Mapa de Correlação
Map(plot.cors, cors, metodos)
## [[1]]
## NULL
##
## [[2]]
## NULL5 Análise de Serie Temporal
Neste momente, após a exploraração de nosso conjunto de dados, será iniciado o estudo de “series temporis” em nosso conjuntos de dados. Será anlisado a demanda de bicicletas ao longo do tempo constuindo um time series plot para alguns determinados horários em dias úteis e dias de fim de semana, para que possamos começar a identificar relações e período de alta e baixa demanda de bicicletas.
library(ggplot2)
times <- c(7, 9, 12, 15, 18, 20, 22)
# Time Series Plot
tms.plot <- function(times){
ggplot(bikes[bikes$workTime == times, ], aes(x = dteday, y = cnt)) +
geom_line() +
ylab('Número de Bikes') +
xlab('Data dia') +
labs(title = paste('Demanda de Bikes as ', as.character(times), ':00', sep =''))+
theme(text = element_text(size = 20))
}
lapply(times, tms.plot)## [[1]]
##
## [[2]]
##
## [[3]]
##
## [[4]]
##
## [[5]]
##
## [[6]]
##
## [[7]]
5.1 Analisando BoxPlots
# Convertendo a variável dayWeek para fator ordenado e plotando em ordem de tempo
fact.conv <- function(inVec){
outVec <- as.factor(inVec)
levels(outVec) <- c("Segunda", "Terca", "Quarta",
"Quinta", "Sexta", "Sabado",
"Domingo")
outVec
}
bikes$dayWeek <- fact.conv(bikes$dayWeek)
# Convertendo a variável isWorking para fator ordenado e plotando em Dia não Útil e Dia Útil
fact.conv1 <- function(inVec){
outVec1 <- as.factor(inVec)
levels(outVec1) <- c("Dia não Útil", "Dia Útil")
outVec1
}
bikes$isWorking <- fact.conv1(bikes$isWorking)
# Convertendo a variável isWorking para fator ordenado e plotando em Dia não Útil e Dia Útil
fact.conv2 <- function(inVec){
outVec2 <- as.factor(inVec)
levels(outVec2) <- c("Primavera", "Verão","Outuno", "Inverso")
outVec2
}
bikes$weathersit <- fact.conv2(bikes$weathersit)
# Demanda de bikes x potenciais variáveis preditoras
labels <- list("Boxplots - Demanda de Bikes por Hora",
"Boxplots - Demanda de Bikes por Estação",
"Boxplots - Demanda de Bikes por Dia Útil",
"Boxplots - Demanda de Bikes por Dia da Semana")
xAxis <- list("hr", "weathersit", "isWorking", "dayWeek")
# Função para criar os boxplots
plot.boxes <- function(X, label){
ggplot(bikes, aes_string(x = X, y = "cnt", group = X)) +
ylab('Número de Bikes alugadas') +
geom_boxplot( ) +
ggtitle(label) +
theme(text = element_text(size = 18))
}
Map(plot.boxes, xAxis, labels)## [[1]]
##
## [[2]]
##
## [[3]]
##
## [[4]]
5.2 Analisando Density Plots
Visualizando o relacionamento entre as variáveis preditoras e demanda por bicicletas.
labels <- c("Demanda de Bikes vs Temperatura",
"Demanda de Bikes vs Humidade",
"Demanda de Bikes vs Velocidade do Vento",
"Demanda de Bikes vs Hora")
xAxis <- c("temp", "hum", "windspeed", "hr")
# Função para os Density Plots
plot.scatter <- function(X, label){
ggplot(bikes, aes_string(x = X, y = "cnt")) +
geom_point(aes_string(colour = "cnt"), alpha = 0.1) +
scale_colour_gradient(low = "green", high = "blue") +
geom_smooth(method = "loess") +
ggtitle(label) +
theme(text = element_text(size = 20))
}
Map(plot.scatter, xAxis, labels)## $temp
##
## $hum
##
## $windspeed
##
## $hr
# Explorando a interação entre tempo e dia, em dias da semana e fins de semana
labels <- list("Box plots - Demanda por Bikes as 09:00 para \n dias da semana e fins de semana",
"Box plots - Demanda por Bikes as 18:00 para \n dias da semana e fins de semana")
Times <- list(9, 18)
plot.box2 <- function(time, label){
ggplot(bikes[bikes$hr == time, ], aes(x = isWorking, y = cnt, group = isWorking)) +
geom_boxplot( ) + ggtitle(label) +
theme(text = element_text(size = 18)) }
Map(plot.box2, Times, labels)## [[1]]
##
## [[2]]
6 Feature Selection
A seleção de Atributos, ou o Feature Selection tem como objetivo a simpleficação do modelo, para facilitar sua interpretação, dredução do tempo de treinamento do modelo e melhoria da generalização do modelo, evitando overfitting. Utilizaremos a tecnicas de feaure selection para automitizar a seleção de variáveis com maior potencial para variáveis preditoras. Sendo uma espécia de filtro, que remove do seu dataset as variáveis qwue não serão úteis para a criação do modelo preditivo. Tem como principal objetivo a criação de um modelo preditoco com a maior precisão possível e que seja generalizável. As técnicas de Feaure Selection basicamente calculam o nível de signifiância de cada variável e eliminam aquelas com significância mais baixa.
dim(bikes)## [1] 10342 16any()## [1] FALSECriando um modelo para identificar os atributos com maior importância para o modelo preditivo
library(randomForest)
Modelo <- randomForest(cnt ~.,
data = bikes,
ntree = 100,
nodesize = 10,
inportance = TRUE)
# Plotando as variáveis por grau de importância
varImpPlot(Modelo)
# Removendo variáveis colineares
Modelo <- randomForest(cnt ~ . - mnth
- hr
- workingday
- isWorking
- dayWeek
- xformHr
- workTime
- holiday
- windspeed
- monthCount
- weathersit,
data = bikes,
ntree = 100,
nodesize = 10,
importance = TRUE)
# Removendo variáveis colineares
varImpPlot(Modelo)
7 Criando um modelo preditivo
# Função para tratar as datas
set.asPOSIXct <- function(inFrame) {
dteday <- as.POSIXct(
as.integer(inFrame$dteday),
origin = "1970-01-01")
as.POSIXct(strptime(
paste(as.character(dteday),
" ",
as.character(inFrame$hr),
":00:00",
sep = ""),
"%Y-%m-%d %H:%M:%S"))
}
char.toPOSIXct <- function(inFrame) {
as.POSIXct(strptime(
paste(inFrame$dteday, " ",
as.character(inFrame$hr),
":00:00",
sep = ""),
"%Y-%m-%d %H:%M:%S")) }7.1 Treinamento o modelo
model <- randomForest(cnt ~ xformWorkHr + dteday + temp + hum,
data = bikes,
ntree = 40,
nodesize = 5)
print(model)##
## Call:
## randomForest(formula = cnt ~ xformWorkHr + dteday + temp + hum, data = bikes, ntree = 40, nodesize = 5)
## Type of random forest: regression
## Number of trees: 40
## No. of variables tried at each split: 1
##
## Mean of squared residuals: 5421.007
## % Var explained: 80.39scores <- data.frame(actual = bikes$cnt,
prediction = predict(model, newdata = bikes))7.2 Avaliando o modelo
inFrame <- scores[, c("actual", "prediction")]
refFrame <- bikes
rbind(head(scores), tail(scores))summary(scores)## actual prediction
## Min. :101.0 Min. :112.2
## 1st Qu.:167.0 1st Qu.:188.6
## Median :246.0 Median :256.3
## Mean :294.1 Mean :294.3
## 3rd Qu.:377.0 3rd Qu.:362.7
## Max. :977.0 Max. :874.1# Criando um dataframe
inFrame[, c("dteday", "monthCount", "hr", "xformWorkHr")] <- refFrame[, c("dteday", "monthCount", "hr", "xformWorkHr")]
# Nomeando o dataframe
names(inFrame) <- c("cnt", "predicted", "dteday", "monthCount", "hr", "xformWorkHr")
# Time series plot mostrando a diferença entre valores reais e valores previstos
inFrame <- inFrame[order(inFrame$dteday),]
s <- c(7, 9, 12, 15, 18, 20, 22)
lapply(s, function(s){
ggplot() +
geom_line(data = inFrame[inFrame$hr == s, ],
aes(x = dteday, y = cnt)) +
geom_line(data = inFrame[inFrame$hr == s, ],
aes(x = dteday, y = predicted), color = "red") +
ylab("Numero de Bikes") +
labs(title = paste("Demanda de Bikes as ",
as.character(s), ":00", spe ="")) +
theme(text = element_text(size = 20))
})## [[1]]
##
## [[2]]
##
## [[3]]
##
## [[4]]
##
## [[5]]
##
## [[6]]
##
## [[7]]
Conforme podemos observar a linha preta é exatamento os dados que temos nosso conjuto de dados original.
A linha vermelha demonstra as nossas previsões com o modelo.
7.3 Computando os resíduos
inFrame <- mutate(inFrame, resids = predicted - cnt)
# Plotando os resíduos
ggplot(inFrame, aes(x = resids)) +
xlab('Resíduos') +
ylab("Quantidade") +
theme_classic() +
geom_histogram(binwidth = 1, fill = "white", color = "steelblue")
# Distribuição os resíduos
qqnorm(inFrame$resids)
qqline(inFrame$resids)
# Plotando os resíduos com as horas transformadas
inFrame <- mutate(inFrame, fact.hr = as.factor(hr),
fact.xformWorkHr = as.factor(xformWorkHr))
facts <- c("fact.hr", "fact.xformWorkHr")
lapply(facts, function(x){
ggplot(inFrame, aes_string(x = x, y = "resids"), fill = "steelblue") +
geom_boxplot( ) +
ggtitle("Residuos - Demanda de Bikes por Hora - Atual vs Previsto")})## [[1]]
##
## [[2]]
head(inFrame)# Mediana dos resíduos por hora
evalFrame <- inFrame %>%
group_by(hr) %>%
summarise(medResidByHr = format(round(
median(predicted - cnt), 2),
nsmall = 2))
# Computando a mediana dos resíduos
tempFrame <- inFrame %>%
group_by(monthCount) %>%
summarise(medResid = median(predicted - cnt))
summary(tempFrame)## monthCount medResid
## Min. : 1.00 Min. :-0.9845
## 1st Qu.: 6.75 1st Qu.: 4.5589
## Median :12.50 Median : 6.0890
## Mean :12.50 Mean : 6.2618
## 3rd Qu.:18.25 3rd Qu.: 8.2514
## Max. :24.00 Max. :13.9239head(evalFrame)
