NYCFlights 13 to create a heatmap that explores Late Arrivals

library(nycflights13)
library(RColorBrewer)
data(flights)
library(dplyr)

## 
## Attaching package: 'dplyr'

## The following objects are masked from 'package:stats':
## 
##     filter, lag

## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union

library(tidyverse)

## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ forcats   1.0.0     ✔ readr     2.1.4
## ✔ ggplot2   3.4.3     ✔ stringr   1.5.0
## ✔ lubridate 1.9.2     ✔ tibble    3.2.1
## ✔ purrr     1.0.2     ✔ tidyr     1.3.0

## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

Initial Scatterplot with loess smoother for distance to delays

flights_nona <- flights |>
  filter(!is.na(distance) & !is.na(arr_delay))  # remove na's for distance and arr_delay

Use group_by and summarise to create summary table

by_tailnum <- flights_nona |>
  group_by(tailnum) |>  
  summarise(count = n(),
        dist = mean(distance),
        delay = mean(arr_delay))
delay <- filter(by_tailnum, count > 20, dist < 2000)

Average delay is slightly related to average sitance flown by a plane

ggplot(delay, aes(dist, delay)) +
  geom_point(aes(size = count), alpha = 1/2) +
  geom_smooth() +
  scale_size_area()

## `geom_smooth()` using method = 'gam' and formula = 'y ~ s(x, bs = "cs")'

## Late Arrivals Affect the Usage Cost of Airports

This was modified form Raul Miranda’s work. Create a dataframe that is composed of summary statistics.

delays <- flights_nona |>
  group_by (dest) |>
  summarize (count = n(),
             dist = mean (distance),
             delay = mean (arr_delay),
             delaycost = mean(count*delay/dist))
delays <- arrange(delays, desc(delaycost))    
head(delays)

## # A tibble: 6 × 5
##   dest  count  dist delay delaycost
##   <chr> <int> <dbl> <dbl>     <dbl>
## 1 DCA    9111  211.  9.07      391.
## 2 IAD    5383  225. 13.9       332.
## 3 ATL   16837  757. 11.3       251.
## 4 BOS   15022  191.  2.91      230.
## 5 CLT   13674  538.  7.36      187.
## 6 RDU    7770  427. 10.1       183.

This shows Reagan National (DCA) with the highest delay cost, and Dulles

library(knitr)
kable(delays, 
      caption = "Table of Mean Distance, Mean Arrival Delay, and Highest Delay Costs",
      digits = 2)

Table of Mean Distance, Mean Arrival Delay, and Highest Delay Costs
dest	count	dist	delay	delaycost
DCA	9111	211.08	9.07	391.36
IAD	5383	224.74	13.86	332.08
ATL	16837	757.14	11.30	251.29
BOS	15022	190.74	2.91	229.53
CLT	13674	538.01	7.36	187.07
RDU	7770	426.73	10.05	183.04
RIC	2346	281.27	20.11	167.74
PHL	1541	94.34	10.13	165.42
BUF	4570	296.87	8.95	137.71
ORD	16566	729.02	5.88	133.54
ROC	2358	259.36	11.56	105.11
BWI	1687	179.35	10.73	100.90
CVG	3725	575.23	15.36	99.50
DTW	9031	498.20	5.43	98.43
CLE	4394	414.00	9.18	97.45
PWM	2288	276.03	11.66	96.65
BNA	6084	758.22	11.81	94.78
FLL	11897	1070.06	8.08	89.86
BTV	2510	265.12	8.95	84.74
MCO	13967	943.11	5.45	80.78
CMH	3326	476.55	10.60	73.99
SYR	1707	206.07	8.90	73.76
MDW	4025	718.09	12.36	69.30
MHT	932	207.38	14.79	66.46
PIT	2746	334.10	7.68	63.13
TPA	7390	1003.93	7.41	54.53
ORF	1434	288.55	10.95	54.41
PBI	6487	1028.82	8.56	53.99
MKE	2709	733.37	14.17	52.33
STL	4142	878.83	11.08	52.21
MSP	6929	1017.46	7.27	49.51
GSO	1492	449.79	14.11	46.81
CHS	2759	632.96	10.59	46.17
ALB	418	143.00	14.40	42.08
CAK	842	397.00	19.70	41.78
DEN	7169	1614.69	8.61	38.21
JAX	2623	824.71	11.84	37.67
PVD	358	160.00	16.23	36.32
DAY	1399	536.91	12.68	33.04
IND	1981	652.26	9.94	30.19
BDL	412	116.00	7.05	25.03
MCI	1885	1097.65	14.51	24.92
GRR	728	605.71	18.19	21.86
TYS	578	638.34	24.07	21.79
SDF	1104	645.96	12.67	21.65
IAH	7085	1407.18	4.24	21.35
GSP	790	595.98	15.94	21.12
MSY	3715	1177.73	6.49	20.47
MEM	1686	954.48	10.65	18.80
SAV	749	709.27	15.13	15.98
MSN	556	803.93	20.20	13.97
SFO	13173	2577.93	2.67	13.66
OMA	817	1135.56	14.70	10.58
RSW	3502	1072.85	3.24	10.57
HOU	2083	1420.26	7.18	10.52
DSM	523	1020.56	19.01	9.74
AUS	2411	1514.25	6.02	9.58
SJU	5773	1599.84	2.52	9.10
TUL	294	1215.00	33.66	8.14
BGR	358	378.00	8.03	7.60
CAE	106	603.70	41.76	7.33
OKC	315	1325.00	30.62	7.28
XNA	992	1142.44	7.47	6.48
ACK	264	199.00	4.85	6.44
BHM	269	866.00	16.88	5.24
BQN	888	1578.99	8.25	4.64
PHX	4606	2141.34	2.10	4.51
CRW	134	444.00	14.67	4.43
AVL	261	583.61	8.00	3.58
LAX	16026	2468.62	0.55	3.55
SRQ	1201	1044.64	3.08	3.54
SAN	2709	2437.28	3.14	3.49
MIA	11593	1091.54	0.30	3.18
SAT	659	1578.18	6.95	2.90
PDX	1342	2445.61	5.14	2.82
DFW	8388	1383.06	0.32	1.95
TVC	95	652.45	12.97	1.89
PSE	358	1617.00	7.87	1.74
CHO	46	305.00	9.50	1.43
SMF	282	2521.00	12.11	1.35
BUR	370	2465.00	8.18	1.23
ILM	107	500.00	4.64	0.99
EGE	207	1735.80	6.30	0.75
LAS	5952	2240.98	0.26	0.68
ABQ	254	1826.00	4.38	0.61
MYR	58	550.67	4.60	0.48
SJC	328	2569.00	3.45	0.44
OAK	309	2576.00	3.08	0.37
JAC	21	1875.90	28.10	0.31
SLC	2451	1986.99	0.18	0.22
BZN	35	1882.00	7.60	0.14
SBN	10	645.40	6.50	0.10
EYW	17	1207.00	6.35	0.09
HDN	14	1728.00	2.14	0.02
MTJ	14	1795.00	1.79	0.01
ANC	8	3370.00	-2.50	-0.01
LGB	661	2465.00	-0.06	-0.02
LEX	1	604.00	-22.00	-0.04
PSP	18	2378.00	-12.72	-0.10
HNL	701	4972.76	-1.37	-0.19
MVY	210	173.00	-0.29	-0.35
STT	518	1626.99	-3.84	-1.22
SEA	3885	2412.68	-1.10	-1.77
SNA	812	2434.00	-7.87	-2.62

Now get the top 100 delay costs to create a heatmap of those flights.

top100 <- delays |>
  head(100) |>
  arrange(delaycost)
row.names(top100) <- top100$dest

## Warning: Setting row names on a tibble is deprecated.

Convert dataframe to matrix form

delays_mat <- data.matrix(top100)
delays_mat2 <- delays_mat[,2:5]

Create a heatmap using colorBrewer

color set, margins=c(7,10) for aspect ratio, titles of graph, x and y labels,font size of x and y labels, and set up a RowSideColors bar

Flights Plot

heatmap(delays_mat2, 
        Rowv = NA, Colv = NA,
        s=0.6, v=1, scale="column", 
        margins=c(7,10), 
        main = "Cost of Late Arrivals", 
        xlab = "Flight Characteristics", 
        ylab="Arrival Airport", labCol =      c("Flights","Distance","Delay","Cost Index"),
        cexCol=1, cexRow =1)

## layout: widths =  0.05 4 , heights =  0.25 4 ; lmat=
##      [,1] [,2]
## [1,]    0    3
## [2,]    2    1

Nneka’s Plot

I want to see how delayed flights are on January 1st compared to other days.

head(flights)

## # A tibble: 6 × 19
##    year month   day dep_time sched_dep_time dep_delay arr_time sched_arr_time
##   <int> <int> <int>    <int>          <int>     <dbl>    <int>          <int>
## 1  2013     1     1      517            515         2      830            819
## 2  2013     1     1      533            529         4      850            830
## 3  2013     1     1      542            540         2      923            850
## 4  2013     1     1      544            545        -1     1004           1022
## 5  2013     1     1      554            600        -6      812            837
## 6  2013     1     1      554            558        -4      740            728
## # ℹ 11 more variables: arr_delay <dbl>, carrier <chr>, flight <int>,
## #   tailnum <chr>, origin <chr>, dest <chr>, air_time <dbl>, distance <dbl>,
## #   hour <dbl>, minute <dbl>, time_hour <dttm>

flightsWOJan1 <- flights |>
  filter(month != 1 & day != 1) |>
  mutate(delayedOrNot = case_when((dep_delay > 0) ~ "Delayed",
                                  (dep_delay == 0) ~ "On Time",
                                  (dep_delay < 0) ~ "Early")) |>
  filter(!is.na(dep_delay))
flightsWOJan1

## # A tibble: 292,086 × 20
##     year month   day dep_time sched_dep_time dep_delay arr_time sched_arr_time
##    <int> <int> <int>    <int>          <int>     <dbl>    <int>          <int>
##  1  2013    10     2      449            500       -11      620            648
##  2  2013    10     2      513            517        -4      736            757
##  3  2013    10     2      537            545        -8      916            933
##  4  2013    10     2      540            545        -5      807            827
##  5  2013    10     2      543            545        -2      813            855
##  6  2013    10     2      546            550        -4      918            932
##  7  2013    10     2      548            600       -12      700            711
##  8  2013    10     2      548            600       -12      700            708
##  9  2013    10     2      550            600       -10      642            700
## 10  2013    10     2      552            600        -8      702            701
## # ℹ 292,076 more rows
## # ℹ 12 more variables: arr_delay <dbl>, carrier <chr>, flight <int>,
## #   tailnum <chr>, origin <chr>, dest <chr>, air_time <dbl>, distance <dbl>,
## #   hour <dbl>, minute <dbl>, time_hour <dttm>, delayedOrNot <chr>

woJan1Graph <- ggplot(flightsWOJan1, aes(x = delayedOrNot, fill = delayedOrNot)) +
  geom_bar()

Making a new dataset with just flights on Janaury 1st.

flightsJan1 <- flights |>
  filter(month == 1 & day == 1) |>
  mutate(delayedOrNot = case_when((dep_delay > 0) ~ "Delayed",
                                  (dep_delay == 0) ~ "On Time",
                                  (dep_delay < 0) ~ "Early")) |>
  filter(!is.na(dep_delay))
flightsJan1

## # A tibble: 838 × 20
##     year month   day dep_time sched_dep_time dep_delay arr_time sched_arr_time
##    <int> <int> <int>    <int>          <int>     <dbl>    <int>          <int>
##  1  2013     1     1      517            515         2      830            819
##  2  2013     1     1      533            529         4      850            830
##  3  2013     1     1      542            540         2      923            850
##  4  2013     1     1      544            545        -1     1004           1022
##  5  2013     1     1      554            600        -6      812            837
##  6  2013     1     1      554            558        -4      740            728
##  7  2013     1     1      555            600        -5      913            854
##  8  2013     1     1      557            600        -3      709            723
##  9  2013     1     1      557            600        -3      838            846
## 10  2013     1     1      558            600        -2      753            745
## # ℹ 828 more rows
## # ℹ 12 more variables: arr_delay <dbl>, carrier <chr>, flight <int>,
## #   tailnum <chr>, origin <chr>, dest <chr>, air_time <dbl>, distance <dbl>,
## #   hour <dbl>, minute <dbl>, time_hour <dttm>, delayedOrNot <chr>

Jan1Graph <- ggplot(flightsJan1, aes(x = delayedOrNot, fill = delayedOrNot)) +
  geom_bar()

Jan1Graph

woJan1Graph

You can tell that flights are slightly more delayed on January 1st but not by a very large margin which is good.

ggplot(flightsJan1, aes(x = delayedOrNot, fill = origin)) +
  geom_bar() +
  scale_fill_discrete(name = "Origin of Flight") +
  labs(
    x = "Delayed, On Time, or Early",
    y = "Counts",
    title = "Counts of Delayed, On Time, and Early Departures",
    legend = "Origin of Flight",
    caption = "This dataset comes from the FAA Aircrafts Registry and displays data of all flights that departed NYC in 2013.",
  )

In my visualization, I have displayed the counts of delayed, on time, and early arrivals for January 1, 2013. First, I filtered the original dataset to only include flights that occured on January 1st. Then, I created a new variable called delayedOrNot which simply tells the audience whether each flight was delayed, on time, or early. Then, I put this information into a bar graph to get the counts and filled this based on the origin of flight. One aspect of my plot that I would like to highlight is the mutation and the use of case_when to mutate based on multiple conditions.

NYC Heatmaps Homework

Nneka Okigbo

2024-02-25