Page Still under construction, Futher insights and examplanations will be added

Excess rentals in TfL bike sharing

We can get the latest data by running the following

url <- "https://data.london.gov.uk/download/number-bicycle-hires/ac29363e-e0cb-47cc-a97a-e216d900a6b0/tfl-daily-cycle-hires.xlsx"

# Download TFL data to temporary file
httr::GET(url, write_disk(bike.temp <- tempfile(fileext = ".xlsx")))

## Response [https://airdrive-secure.s3-eu-west-1.amazonaws.com/london/dataset/number-bicycle-hires/2021-12-20T06%3A47%3A04/tfl-daily-cycle-hires.xlsx?X-Amz-Algorithm=AWS4-HMAC-SHA256&X-Amz-Credential=AKIAJJDIMAIVZJDICKHA%2F20220109%2Feu-west-1%2Fs3%2Faws4_request&X-Amz-Date=20220109T164559Z&X-Amz-Expires=300&X-Amz-Signature=618b8aa86d97e1998bd14fe2a3f70fc97ac4b29b4de27607e836b5c2c63936f3&X-Amz-SignedHeaders=host]
##   Date: 2022-01-09 16:46
##   Status: 200
##   Content-Type: application/vnd.openxmlformats-officedocument.spreadsheetml.sheet
##   Size: 176 kB
## <ON DISK>  /var/folders/4d/wfrqtf8n1yz65xx86ycctqb40000gn/T//RtmpI3mf7y/file10fac2609d94e.xlsx

# Use read_excel to read it as dataframe
bike0 <- read_excel(bike.temp,
                   sheet = "Data",
                   range = cell_cols("A:B"))

# change dates to get year, month, and week
bike <- bike0 %>% 
  clean_names() %>% 
  rename (bikes_hired = number_of_bicycle_hires) %>% 
  mutate (year = year(day),
          month = lubridate::month(day, label = TRUE),
          week = isoweek(day))

expected_monthly <- bike%>%
  filter(day >= dmy("01/01/2016"), day<dmy("01/01/2020"))%>%
  group_by(month)%>%
  summarise(expected_avg = mean(bikes_hired))

monthly_rentals <- bike%>%
  filter(day >= dmy("01/01/2016"))%>%
  group_by(year,month) %>% 
  summarise(actual_avg=mean(bikes_hired)) %>% 
  left_join(expected_monthly, by = "month")

monthly_rentals %>% 
  ggplot(aes(x=as.numeric(month)))+
  geom_line(aes(y=expected_avg),color="blue")+
  geom_line(aes(y=actual_avg),color = "black")+
  geom_ribbon(aes(ymin=expected_avg, ymax=pmax(actual_avg,expected_avg)),fill="springgreen1", alpha = 0.3) +
  geom_ribbon(aes(ymin=pmin(actual_avg,expected_avg), ymax=expected_avg), fill="tomato", alpha = 0.3)+
  facet_wrap(~year)+
  theme_bw()+
  theme(legend.position = "none",
        strip.background = element_blank(),
        panel.border = element_blank(),
        plot.title = element_text(size = 9),
        plot.subtitle = element_text(size = 7),
        strip.text.x = element_text(size = 5),
        axis.text.y = element_text(size = 5),
        axis.text.x = element_text(size = 5))+
  scale_x_continuous(labels = function(x) month.abb[x])+
  labs(title = "Monthly change in Tfl bike rentals",
       subtitle = "Change from montly average shown in Blue and calculated between 2016-2019",
       x = "Month",
       y = "Bikes rentals")

The second one looks at percentage changes from the expected level of weekly rentals. The two gray shaded rectangles correspond to Q2 (weeks 14-26) and Q4 (weeks 40-52).

expected_weekly <- bike %>% 
  filter(day>=dmy("4/1/2016") & day<=dmy("29/12/2019")) %>% 
  group_by(week) %>% 
  summarise(expected_rentals=mean(bikes_hired))

weekly_rentals <- bike %>% 
  filter(day>dmy("4/1/2016")) %>% 
  group_by(year,week) %>%
  mutate(yearminusone = year - 1,
         year_week = ifelse(week==53 & month=="Jan",
                            paste(yearminusone,week,sep="-"),
                            paste(year,week,sep="-"))) %>%
  group_by(year_week) %>%
  mutate(actual_rentals = mean(bikes_hired)) %>% 
  filter(day==max(day)) %>%
  ungroup() %>%
  left_join(expected_weekly,by =c("week")) %>% 
  mutate(delta=(actual_rentals/expected_rentals- 1),
         delta = replace_na(delta, 1),
         month=ifelse(week==53,"Dec",month),
         year=ifelse(week==53,year-1,year)) %>% 
  add_row(year=2016,week=53,delta=0)

           

weekly_rentals %>% 
  ggplot(aes(x=week,
             y=delta))+
  geom_line(aes(y = delta)) +
  annotate("rect", xmin = 13, xmax = 26, ymin = -Inf, ymax = Inf, fill = "grey", alpha = 0.3)+
  annotate("rect", xmin = 39, xmax = 53, ymin = -Inf, ymax = Inf, fill = "grey", alpha = 0.3)+
  geom_ribbon(aes(ymin=0, ymax=pmax(0, delta), fill="#eab5b7", alpha = 0.3)) +
  geom_ribbon(aes(ymin=pmin(0, delta), ymax=0, fill="#c0e0c3", alpha = 0.3))+
  geom_rug(data=subset(weekly_rentals,delta>=0),color="#c0e0c3",sides="b")+
  geom_rug(data=subset(weekly_rentals,delta<0),color="#eab5b7",sides="b")+
  facet_wrap(~year)+
  scale_y_continuous(labels = scales::percent)+
  labs(title="Weekly changes in TfL bike rentals",
       subtitle="% change from weekly averages \ncalculated between 2016-2019",
       x="week",
       y="")+
  scale_x_continuous(breaks = c(13,26,39,53))+
  theme_bw()+
  theme(legend.position = "none",
        strip.background = element_blank(),
        panel.border = element_blank(),
        plot.title = element_text(size = 9),
        plot.subtitle = element_text(size = 7),
        strip.text.x = element_text(size = 5),
        axis.text.y = element_text(size = 5),
        axis.text.x = element_text(size = 5))