Message Boards Message Boards

[GIF] Drug overdose trends in USA counties 1999 - 2014

GROUPS:

The data Drug Poisoning Mortality: United States, 1999–2014 are published by USA government. In a few recent blogs (1, 2, 3) static visualizations of data were performed. Here we show how to animate maps of geographical drug overdose spread in USA. Below you can see 4 images, each reflecting upon Age-adjusted death rates for drug poisoning per 100,000 population by county and year:

  1. First static frame 1999
  2. Last static frame 2014
  3. Animated .GIF of the whole period with 1 frame per year
  4. Range of rates versus time, USA average

Quoting NPR news Obama Asks Congress For More Money To Fight Opioid Drug Abuse:

Every day in America more than 50 people die from an overdose of prescription pain medication. Some people who start out abusing pain pills later turn to heroin, which claims another 29 lives each day.


1999: Age-adjusted death rates for drug poisoning per 100,000 population by county and year

enter image description here

enter image description here


2014: Age-adjusted death rates for drug poisoning per 100,000 population by county and year

enter image description here

enter image description here


1999 - 2014 Animation: Age-adjusted death rates for drug poisoning per 100,000 population by county and year

enter image description here

enter image description here


Range of rates versus time: Age-adjusted death rates for drug poisoning per 100,000 for USA average over counties

enter image description here

Getting the data

We can download data in .CSV format from CDC web site. I keep data file in the same as the notebook directory to shorten file-path strings.

SetDirectory[NotebookDirectory[]]
raw = SemanticImport["ops.csv"]

enter image description here

Making "interpreted" dataset

In Wolfram Language (WL) many built-in data allow for interpretation of imported data. For example, the USA counties could be interpreted as entities:

enter image description here

But I did not use SemanticImport to interpret on import automatically, because I would like to do this efficiently. The table has 50247 entries

Normal[raw[All, "County"]] // Length

50247

while there are only 3141 actual counties listed:

Normal[raw[All, "County"]] // Union // Length    

3141

So instead of making 50247 calls to interpreter we will make just 3141 and use efficient Dispatch after to distribute replacement rules over all 50247 entries. I've spent only 100 seconds on making Dispatch

countyRULEs = Dispatch[
    Thread[# -> Interpreter["USCounty"][#]] &@
     Union[Normal[raw[All, "County"]]]]; // AbsoluteTiming

{108.124, Null}

And almost no time on interpreting dataset:

data = raw /. countyRULEs; // AbsoluteTiming
data

{0.441731, Null}

enter image description here

Bounds of death-rates for future rescaling

Note a StringReplace trick for going ToExpression here and throughout the rest of the post:

MinMax[ToExpression[StringReplace[Normal[
data[All, "Estimated Age-adjusted Death Rate, 11 Categories (in ranges)"]], {"-" -> "+", ">" -> "2*"}]]/2]

{1, 20}

Testing color scheme

Color scheme are important to properly blend with native colors of maps and also to express data. These are some tests with Color Schemes available in Wolfram Language.

tmp = GeoNearest["City", 
   Entity["City", {"Atlanta", "Georgia", "UnitedStates"}], {All, Quantity[50, "Kilometers"]}];

Multicolumn[Table[
  GeoRegionValuePlot[tmp -> "PopulationDensity", PlotLegends -> False,
    ColorFunction -> (ColorData[{clmap, "Reverse"}][#] &), ImageSize -> 400]
  , {clmap, {"CherryTones", "SolarColors", "SunsetColors", 
    "RustTones", "WatermelonColors", "Rainbow", "RoseColors", 
    "ThermometerColors", "BrownCyanTones"}}], 3]

enter image description here

Year 1999: a specific year GiS plot

GeoRegionValuePlot[

  Thread[Normal[data[Select[#Year == 1999 &], "County"]] -> 
    ToExpression[StringReplace[Normal[data[Select[#Year == 1999 &]][All, 
         "Estimated Age-adjusted Death Rate, 11 Categories (in ranges)"]], {"-" -> "+", ">" -> "2*"}]]/2],

  GeoRange -> {{24, 50}, {-125, -66}},
  GeoProjection -> "Mercator",
  ColorFunctionScaling -> False,
  ColorFunction -> (ColorData[{"CherryTones", "Reverse"}][
      Rescale[#, {1, 20}]] &),
  PlotLegends -> False,
  ImageSize -> 1000] // Rasterize

Making animation

frames = ParallelTable[
   GeoRegionValuePlot[

    Thread[
     Normal[data[Select[#Year == year &], "County"]] -> 
      ToExpression[StringReplace[Normal[data[Select[#Year == year &], 
           "Estimated Age-adjusted Death Rate, 11 Categories (in ranges)"]], {"-" -> "+", ">" -> "2*"}]]/2],

    GeoRange -> {{24, 50}, {-125, -66}},
    GeoProjection -> "Mercator",
    ColorFunctionScaling -> False,
    ColorFunction -> (ColorData[{"CherryTones", "Reverse"}][
        Rescale[#, {1, 20}]] &),
    PlotLegends -> False,
    ImageSize -> 800],
   {year, Range[1999, 2014]}];

Making legend

Panel@Grid[Transpose[{#, ColorData[{"CherryTones", "Reverse"}][Rescale[#, {1, 20}]]} & /@Range[1, 20]]]

Growth of death rates ranges vs time

bandGrowth = Transpose[Table[N[Mean[ToExpression[
      StringReplace[Normal[data[Select[#Year == y &]][All, 
         "Estimated Age-adjusted Death Rate, 11 Categories (in \
ranges)"]], {"-" -> "~List~", ">" -> "{#,#}&@"}]]]], {y, Range[1999, 2014]}]]

BarChart[{#[[1]], #[[2]] - #[[1]]} & /@ Transpose[bandGrowth], 
 PlotTheme -> "Marketing", ChartLayout -> "Stacked", 
 ChartLabels -> {Range[1999, 2014], None}, ImageSize -> 850, 
 AspectRatio -> 1/3, ChartStyle -> {Yellow, Red}]

Another color scheme sample

In this dark-low-values color scheme you can see better a few white spots. Those are very few counties where data are missing.


1999

enter image description here


2014

enter image description here

Attachments:
POSTED BY: Vitaliy Kaurov
Answer
1 year ago

Great post, but I really hope that it is about the range 1999 - 2014, and not 1999 - 2104 because extrapolation tends to become somewhat unreliable :)

POSTED BY: Markus Roellig
Answer
1 year ago

Thank you, @Markus, I corrected the typos I could find.

POSTED BY: Vitaliy Kaurov
Answer
1 year ago

Really great post Vitaly!

POSTED BY: Valentina Biagini
Answer
7 months ago

Group Abstract Group Abstract