Data Visualization in R: Making Maps

Who goes to the Metropolitan Museum of Art?

Located on the Upper East Side of Manhattan, and one of the prime museum attractions in New Work, this massive art museum draws large crowds every day. Let’s focus on visitors who take a taxi to the museum. What can we say about these visitors?

First we need to decide on what trips might be trips to the museum. This is not obvious - people can get off a cab near the museum but not actually go to the museum. We will ignore difficulties like this in the following. Let’s start by getting a map of the city block where the museum is located:

ny.map <- get_map("1015 5th Ave, New York, NY", color="bw",zoom=18)
ggmap(ny.map)

Using the latitude and longitude information the map, we can grab trips that end near the museum entry:

library(lubridate)
## Pick coordinates that approximates dropoffs near the Met
lat <- c(40.7785,40.780)
lon <- c(-73.963,-73.9615)

taxi <- readRDS('data/yellow_trip_2015-06.rds') %>%
  mutate(weekday.pickup = wday(tpep_pickup_datetime,label=TRUE,abbr=TRUE),                           
         weekday.dropoff = wday(tpep_dropoff_datetime,label=TRUE,abbr=TRUE),                           
         hour.trip.start = factor(hour(tpep_pickup_datetime)),                                 
         hour.trip.end = factor(hour(tpep_dropoff_datetime)),                                  
         day = factor(mday(tpep_dropoff_datetime)),                                            
         trip.duration = as.numeric(difftime(tpep_dropoff_datetime,tpep_pickup_datetime,units="mins")), 
         trip.speed = ifelse(trip.duration > 1, trip_distance/(trip.duration/60), NA),          
         payment_type2 = cut(payment_type, 
                             breaks = c(0,1,2,5), 
                             labels=c('Credit Card','Cash','Other'))) %>%
  filter(day %in% c(1:28))

## Filter data for drop-offs near the Met
taxi.drop.met <- taxi %>%
  filter(dropoff_longitude > lon[1] & dropoff_longitude < lon[2],
         dropoff_latitude > lat[1] & dropoff_latitude < lat[2]) 

ggmap(ny.map) + 
  geom_point(data=taxi.drop.met,
             aes(x=dropoff_longitude,y=dropoff_latitude),size=.03,alpha=0.3,color="red")+
  ggtitle('Taxi Dropoffs near the Met')

Let’s assume that these represent trips to the Met. Where did they originate? We can answer that by plotting the origin latitude and longitude. We need a new map to capture a wider area - here we center it around Central Park:

ny.map <- get_map("Central Park, New York, NY", color="bw",zoom=13)

ggmap(ny.map) + 
  geom_point(data=taxi.drop.met,
             aes(x=pickup_longitude,y=pickup_latitude),size=.03,alpha=0.3,color="blue")+
  geom_point(data=taxi.drop.met,
             aes(x=dropoff_longitude,y=dropoff_latitude),size=.03,alpha=0.3,color="red")+
   theme(axis.ticks = element_blank(),
        axis.text = element_blank())

The majority of trips ending with a dropoff near the Met originate on the Upper East and West side and the Midtown neighborhood. Very few trips originate in the lower part of Manhattan and from Harlem.

What time do these trips end?

taxi.drop.met %>%
  group_by(hour.trip.end) %>%
  summarize(n=n()) %>%
  ggplot(aes(x=hour.trip.end,y=n)) + geom_point() + 
  geom_line(aes(group=1),linetype='dotted')+
  ylab('Trips')+xlab('Hour of Day')+
  ggtitle('Taxi Arrivals near the Met by Time of Day')

What time do you think the Met opens……?

How are trips distributed throughout weekdays?

taxi.drop.met %>%
  ggplot(aes(x=weekday.dropoff)) + 
  geom_bar() + xlab('Day of Week') + ylab('Trips') +
  ggtitle('Taxi Arrivals near the Met by Weekday')

How do people pay?

library(scales)

taxi.drop.met %>%
  filter(!payment_type2=='Other') %>%
  ggplot(aes(x=payment_type2)) + 
  geom_bar(aes(y=..count../sum(..count..),fill=payment_type2)) +
  scale_y_continuous(labels=percent)+
  theme(legend.position="none")+
  xlab('Passenger Count')+ylab('Percent of Trips')+
  ggtitle('Payment for Taxi Trips to the Met')

Is type of payment correlated with origin of trip?

ggmap(ny.map) + 
  geom_point(data=filter(taxi.drop.met,!payment_type2=='Other'),
             aes(x=pickup_longitude,y=pickup_latitude,color=payment_type2),size=.05,alpha=0.3) + 
  facet_wrap(~payment_type2)+
  theme(axis.ticks = element_blank(),
        axis.text = element_blank(),
        legend.position="none")

It seems like Cash trips have a relatively higher likelihood of originating in the Midtown district.

Finally, how do people tip?

taxi.drop.met %>%
  filter(payment_type2=='Credit Card') %>%
  mutate(tip.pct=tip_amount/(total_amount-tip_amount)) %>%
  filter(tip.pct < 0.40) %>%
  ggplot(aes(x=tip.pct)) + geom_density(fill='red',alpha=0.4) +
  scale_x_continuous(labels=percent)+xlab('Tip Size')+
  ggtitle('Tips for Taxi Trips to the Met')

12 Hours in the Meatpacking District

In the early 20th century, the meatpacking district in Manhattan was home to a large number of slaughterhouses and meat packing plants. In the early 21st century, it is instead home to a large number of bars and restaurants. It is a very popular destination for going out in Manhattan. But when and where do people go out?

Let’s diagnose the taxi traffic patterns over the 12 hour period from Thursday 6pm to Friday 5am. Are their particular spots where riders are dropped off and picked up? And how does this activity change over the 12 hour period? A neat way to visualize this is to combine the “small multiples” approach (using ggplot’s facet_wrap option) with a heatmap of activity. This heatmap will “smooth out” neighboring points on the map. Clusters with high activity (i.e., many dropoffs (or pickups)) will be “hotter” (here more red).

We start by grabbing a map centered on the meatpacking district. We choose a high level of zoom:

ny.map <- get_map("Meatpacking District, New York, NY", color="bw",zoom=17)

Next we pick the required slice of time and add some nice labels:

weekday.time.segment <- c('Thurs 18','Thurs 19','Thurs 20','Thurs 21','Thurs 22','Thurs 23','Fri 0','Fri 1','Fri 2','Fri 3','Fri 4','Fri 5')
weekday.time.segment.labels <- c('Thu 6PM','Thu 7PM','Thu 8PM','Thu 9PM','Thu 10PM','Thu 11PM','Fri 12AM','Fri 1AM','Fri 2AM','Fri 3AM','Fri 4AM','Fri 5AM')


plot.df <- taxi %>%
  unite(weekday.drop.time, weekday.dropoff,hour.trip.end,sep=" ") %>%
  filter(weekday.drop.time %in% weekday.time.segment) %>%
  mutate(weekday.drop.time = factor(weekday.drop.time,
                                    levels=weekday.time.segment,
                                    labels=weekday.time.segment.labels))

Finally, we plot the heatmaps:

ggmap(ny.map)+
  stat_density2d(data = plot.df,
                 aes(x = dropoff_longitude, y = dropoff_latitude,fill = ..level.., alpha = ..level..), 
                 geom = "polygon") + 
  scale_fill_gradient(low = "green", high = "red") + 
  scale_alpha(range = c(0, 0.75), guide = FALSE) +
  ggtitle('Meatpacking District Taxi Ride Dropoffs')+
  facet_wrap(~weekday.drop.time,nrow = 3)+
  theme(axis.ticks = element_blank(),
        axis.text = element_blank(),
        legend.position="none")

Let’s repeat this exercise for pick-ups:

plot.df <- taxi %>%
  unite(weekday.pickup.time, weekday.dropoff,hour.trip.start,sep=" ") %>%
  filter(weekday.pickup.time %in% weekday.time.segment) %>%
  mutate(weekday.pickup.time = factor(weekday.pickup.time,
                                    levels=weekday.time.segment,
                                    labels=weekday.time.segment.labels))

ggmap(ny.map)+
  stat_density2d(data = plot.df,
                 aes(x = pickup_longitude, y = pickup_latitude,fill = ..level.., alpha = ..level..), 
                 geom = "polygon") + 
  scale_fill_gradient(low = "green", high = "red") + 
  scale_alpha(range = c(0, 0.75), guide = FALSE) +
  ggtitle('Meatpacking District Taxi Ride Pick-ups, June 2015')+
  facet_wrap(~weekday.pickup.time,nrow = 3)+
  theme(axis.ticks = element_blank(),
        axis.text = element_blank(),
        legend.position="none")