Visualizing Chicago Public Transit Ridership

Table 1 Routes with most stops

#What is the route with the most stops?
routes <- 
  raw_df %>%
  separate_rows(routes) %>%
  group_by(routes) %>%
  summarise(Number_of_stops=n_distinct(stop_id)) %>%
  arrange(desc(Number_of_stops))

kable(routes[1:10, ],  booktabs = T) %>%
  kable_styling(bootstrap_options = "striped", full_width = F, position = "left")

Table 2 Stops with the most routes

#What is the stop with the most routes?
stops <- 
  raw_df %>%
  mutate(number_of_routes = str_count(routes, "\\d+")) %>%
  arrange(desc(number_of_routes)) %>%
  select(stop_id,on_street, cross_street, routes, number_of_routes)

kable(stops[1:10, ], booktabs = T) %>%
  kable_styling(bootstrap_options = "striped", full_width = F, position = "left")

Table 3 Top 10 most trafficked routes

#routes by boarding and alighting ridership 
ridership_by_routes<- 
  stops_route %>%
  filter(!is.na(routes)) %>%
  group_by(routes, type) %>%
  summarise(n=sum(ridership)) %>%
  spread(type, n) %>%
  mutate(total =boardings+ alightings) %>%
  arrange(desc(total))

kable(ridership_by_routes[1:10, ], booktabs = T) %>%
  kable_styling(bootstrap_options = "striped", full_width = F, position = "left")

Figure 3 Stops segmentation based on Ridership

#reshape df with only lat, lon, boardings, and alights columns
#scale the dataset
km_df_scale<- 
  raw_df%>%
  select(stop_id,boardings,alightings) %>%
  column_to_rownames(var="stop_id") %>%
  scale()

library(factoextra)
set.seed(123)
# function to compute total within-cluster sum of square 
wss <- function(k) {
  kmeans(km_df_scale, k,iter.max = 100, nstart = 25 )$tot.withinss
}

# Compute and plot wss for k = 1 to k = 15
k.values <- 1:15

# extract wss for 2-15 clusters
wss_values <- map_dbl(k.values, wss)

#plot optimal K
plot(k.values, wss_values,
       type="b", pch = 19, frame = FALSE, 
       xlab="Number of clusters K",
       ylab="Total within-clusters sum of squares")

set.seed(123)

#kmeans with 3 clusters
km.res <- kmeans(km_df_scale, 3, iter.max = 100, nstart = 25)

#join with raw df
dd <- cbind(raw_df, cluster = km.res$cluster)

#plot
dd %>%
  ggplot(aes(x=boardings, y= alightings, color= factor(cluster))) +
  geom_point() +
  geom_abline(aes(intercept = 0 , slope= 1 ), linetype= "dashed") + 
  scale_x_continuous(trans = 'log') +
  scale_y_continuous(trans = 'log') +
  scale_size(range = c(0.5, 5))  +
  scale_color_brewer("", palette = "Set1", 
                     labels = c("Stops with little ridership", 
                                "Stops with most ridership", 
                                "Stops with medium ridership")) +
  theme_bw() +
  xlab("Boardings") +
  ylab("Alightings") 

#visualize on a map
m = leaflet() %>%
    setView(lng=-87.705, lat=41.85443, zoom = 10) %>% 
    addProviderTiles(providers$Stamen.Toner,group="Stamen Toner") 

# subset into clusters 
data_filterlist = list(cluster_1 = subset(dd, cluster == 1),
                cluster_2 = subset(dd, cluster == 2),
                cluster_3 = subset(dd, cluster == 3))

# Remember we also had these groups associated with each variable? Let's put them in a list too:
layerlist = c("Stops with little ridership", "Stops with most ridership", "Stops with medium ridership")

# We can keep that same color variable:
colorFactors = colorFactor(c('red', 'blue', 'seagreen'), domain=dd$cluster)

# Now we have our loop - each time through the loop, it is adding our markers to the map object:

for (i in 1:length(data_filterlist)){
  m = addCircleMarkers(m, 
                       lng=data_filterlist[[i]]$lon, 
                       lat=data_filterlist[[i]]$lat, 
                       radius=1,
                       popup= paste( "Stop_id:",data_filterlist[[i]]$stop_id,  
                                     "<br>", "Routes:", data_filterlist[[i]]$routes,
                                     "<br>", "Boardings:",data_filterlist[[i]]$boardings,
                                     "<br>", "Alightings:",data_filterlist[[i]]$alightings),
                       stroke = FALSE, fillOpacity = 0.75,
                       color = colorFactors(data_filterlist[[i]]$cluster),
                       group = layerlist[i]
  )

}


p2<- addLayersControl(m, overlayGroups = layerlist, options = layersControlOptions(collapsed = FALSE))

frameWidget(p2, width='100%')