Data on quantiles of the distributions of family incomes in the United States. This combines three data sources:
(1) US Census Table F1 for the central quantiles
(2) Piketty and Saez for the 95th and higher quantiles
(3) Gross Domestic Product and implicit price deflators from MeasuringWorth.com
1 
A data.frame
containing:
numeric year 1947:2012
number of families in the US
quintile1, quintile2, quintile3, quintile4, and p95 are the indicated quantiles of the distribution of family income from US Census Table F1. The media is computed as the geometric mean of quintile2 and quintile3. This is accurate to the extent that the lognormal distribution adequately approximates the central 20 percent of the income distribution, which it should for most practical purposes.
The indicated quantiles of family income per Piketty and Saez
real GDP in millions, GDP implicit price deflators, US population in thousands, and real GDP per capita, according to MeasuringWorth.com.
ratio of the estimates of the 95th percentile of distributions of family income from the Piketty and Saez analysis of data from the Internal Revenue Service (IRS) and from the US Census Bureau.
The IRS has ranged between 72 and 98 percent of the Census Bureau figures for the 95th percentile of the distribution, with this ratio averaging around 75 percent since the late 1980s. However, this systematic bias is modest relative to the differences between the different quantiles of interest in this combined dataset.
average number of persons per family using the number of families from US Census Table F1 and the population from MeasuringWorth.com.
personsPerFamily * realGDPperCap
ratio of realGDPperFamily to the median. This is a measure of skewness and income inequality.
For details on how this data.frame
was created, see
"F1.PikettySaez.R" in system.file('scripts', package='fda')
.
This provides links for files to download and R commands to read those
files and convert them into an updated version of
incomeInequality
. This is a reasonable thing to do if it is
more than 2 years since max(incomeInequality$year)
. All data
are in constant 2012 dollars.
Spencer Graves
United States Census Bureau, Table F1. Income Limits for Each Fifth and Top 5 Percent of Families, All Races, http://www.census.gov/data/tables/timeseries/demo/incomepoverty/historicalincomeinequality.html, accessed 20161209.
Thomas Piketty and Emmanuel Saez (2003) "Income Inequality in the United States, 19131998", Quarterly Journal of Economics, 118(1) 139, http://elsa.berkeley.edu/~saez, update accessed February 28, 2014.
Louis Johnston and Samuel H. Williamson (2011) "What Was the U.S. GDP Then?" MeasuringWorth, http://www.measuringworth.org/usgdp, accessed February 28, 2014.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208  ##
## Rato of IRS to census estimates for the 95th percentile
##
data(incomeInequality)
plot(P95IRSvsCensus~Year, incomeInequality, type='b')
# starts ~0.74, trends rapidly up to ~0.97,
# then drifts back to ~0.75
abline(h=0.75)
abline(v=1989)
# check
sum(is.na(incomeInequality$P95IRSvsCensus))
# The Census data runs to 2011; Pikety and Saez runs to 2010.
quantile(incomeInequality$P95IRSvsCensus, na.rm=TRUE)
# 0.72 ... 0.98
##
## Persons per Family
##
plot(personsPerFamily~Year, incomeInequality, type='b')
quantile(incomeInequality$personsPerFamily)
# ranges from 3.72 to 4.01 with median 3.84
#  almost 4
##
## GDP per family
##
plot(realGDPperFamily~Year, incomeInequality, type='b', log='y')
##
## Plot the mean then the first quintile, then the median,
## 99th, 99.9th and 99.99th percentiles
##
plotCols < c(21, 3, 5, 11, 13:14)
kcols < length(plotCols)
plotColors < c(1:6, 8:13)[1:kcols] # omit 7=yellow
plotLty < 1:kcols
matplot(incomeInequality$Year, incomeInequality[plotCols]/1000,
log='y', type='l', col=plotColors, lty=plotLty)
#*** Growth broadly shared 1947  1970, then began diverging
#*** The divergence has been most pronounced among the top 1%
#*** and especially the top 0.01%
##
## Growth rate by quantile 19471970 and 1970  present
##
keyYears < c(1947, 1970, 2010)
(iYears < which(is.element(incomeInequality$Year, keyYears)))
(dYears < diff(keyYears))
kk < length(keyYears)
(lblYrs < paste(keyYears[kk], keyYears[1], sep=''))
(growth < sapply(incomeInequality[iYears,], function(x, labels=lblYrs){
dxi < exp(diff(log(x)))
names(dxi) < labels
dxi
} ))
# as percent
(gr < round(100*(growth1), 1))
# The average annual income (realGDPperFamily) doubled between
# 1970 and 2010 (increased by 101 percent), while the median household
# income increased only 23 percent.
##
## Income lost by each quantile 19702010
## relative to the broadly shared growth 19471970
##
(lostGrowth < (growth[, 'realGDPperFamily']growth[, plotCols]))
# 19471970: The median gained 20% relative to the mean,
# while the top 1% lost ground
# 19702010: The median lost 79%, the 99th percentile lost 29%,
# while the top 0.1% gained
(lostIncome < (lostGrowth[2, ] *
incomeInequality[iYears[2], plotCols]))
# The median family lost $39,000 per year in income
# relative to what they would have with the same economic growth
# broadly shared as during 19471970.
# That's slightly over $36,500 per year = $100 per day
(grYr < growth^(1/dYears))
(grYr. < round(100*(grYr1), 1))
##
## Regression line: linear spline
##
(varyg < c(3:14, 21))
Varyg < names(incomeInequality)[varyg]
str(F01ps < reshape(incomeInequality[c(1, varyg)], idvar='Year',
ids=F1.PikettySeaz$Year,
times=Varyg, timevar='pctile',
varying=list(Varyg), direction='long'))
names(F01ps)[2:3] < c('variable', 'value')
F01ps$variable < factor(F01ps$variable)
# linear spline basis function with knot at 1970
F01ps$t1970p < pmax(0, F01ps$Year1970)
table(nas < is.na(F01ps$value))
# 6 NAs, one each of the PikettySaez variables in 2011
F01i < F01ps[!nas, ]
# formula:
# log(value/1000) ~ b*Year + (for each variable:
# different intercept + (different slope after 1970))
Fit < lm(log(value/1000)~Year+variable*t1970p, F01i)
anova(Fit)
# all highly significant
# The residuals may show problems with the model,
# but we will ignore those for now.
# Model predictions
str(Pred < predict(Fit))
##
## Combined plot
##
# Plot to a file? Wikimedia Commons prefers svg format.
svg('incomeInequality8.svg')
# If you want software to convert svg to another format such as png,
# consider GIMP (www.gimp.org).
# Base plot
# Leave extra space on the right to label with growth since 1970
op < par(mar=c(5, 4, 4, 5)+0.1)
matplot(incomeInequality$Year, incomeInequality[plotCols]/1000,
log='y', type='l', col=plotColors, lty=plotLty,
xlab='', ylab='', las=1, axes=FALSE, lwd=3)
axis(1, at=seq(1950, 2010, 10),
labels=c(1950, NA, 1970, NA, 1990, NA, 2010), cex.axis=1.5)
yat < c(10, 50, 100, 500, 1000, 5000, 10000)
axis(2, yat, labels=c('$10K', '$50K', '$100K', '$500K',
'$1M', '$5M', '$10M'), las=1, cex.axis=1.2)
# Label the lines
pctls < paste(c(20, 40, 50, 60, 80, 90, 95, 99, 99.5, 99.9, 99.99),
'%', sep='')
lineLbl0 < c('Year', 'families K', pctls,
'realGDP.M', 'GDP deflator', 'popK', 'realGDPperFamily',
'95 pct(IRS / Census)', 'size of household',
'average family income', 'mean/median')
(lineLbls < lineLbl0[plotCols])
sel75 < (incomeInequality$Year==1975)
laby < incomeInequality[sel75, plotCols]/1000
text(1973.5, c(1.2, 1.2, 1.3, 1.5, 1.9)*laby[1], lineLbls[1], cex=1.2)
text(1973.5, 1.2*laby[1], lineLbls[1], cex=1.2, srt=10)
##
## Add lines + points for the knots in 1970
##
End < numeric(kcols)
F01names < names(incomeInequality)
for(i in seq(length=kcols)){
seli < (as.character(F01i$variable) == F01names[plotCols[i]])
# with(F01i[seli, ], lines(Year, exp(Pred[seli]), col=plotColors[i]))
yri < F01i$Year[seli]
predi < exp(Pred[seli])
lines(yri, predi, col=plotColors[i])
End[i] < predi[length(predi)]
sel70i < (yri==1970)
points(yri[sel70i], predi[sel70i], col=plotColors[i])
}
##
## label growth rates
##
table(sel70. < (incomeInequality$Year>1969))
(lastYrs < incomeInequality[sel70., 'Year'])
(lastYr. < max(lastYrs)+4)
#text(lastYr., End, gR., xpd=NA)
text(lastYr., End, paste(gr[2, plotCols], '%', sep=''), xpd=NA)
text(lastYr.+7, End, paste(grYr.[2, plotCols], '%', sep=''), xpd=NA)
##
## Label the presidents
##
abline(v=c(1953, 1961, 1969, 1977, 1981, 1989, 1993, 2001, 2009))
(m99.95 < with(incomeInequality, sqrt(P99.9*P99.99))/1000)
text(1949, 5000, 'Truman')
text(1956.8, 5000, 'Eisenhower', srt=90)
text(1963, 5000, 'Kennedy', srt=90)
text(1966.8, 5000, 'Johnson', srt=90)
text(1971, 5*m99.95[24], 'Nixon', srt=90)
text(1975, 5*m99.95[28], 'Ford', srt=90)
text(1978.5, 5*m99.95[32], 'Carter', srt=90)
text(1985.1, m99.95[38], 'Reagan' )
text(1991, 0.94*m99.95[44], 'GHW Bush', srt=90)
text(1997, m99.95[50], 'Clinton')
text(2005, 1.1*m99.95[58], 'GW Bush', srt=90)
text(2010, 1.2*m99.95[62], 'Obama', srt=90)
##
## Done
##
par(op) # reset margins
dev.off() # for plot to a file

Questions? Problems? Suggestions? Tweet to @rdrrHQ or email at ian@mutexlabs.com.
Please suggest features or report bugs with the GitHub issue tracker.
All documentation is copyright its authors; we didn't write any of that.