Drug overdose trends in USA counties 1999 – 2014

Posted by & filed under Code, Data, Mathematica, Wolfram, Wolfram Language.

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

6105figure2


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.

<code>SetDirectory[NotebookDirectory[]]
raw = SemanticImport["ops.csv"]
</code>

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

<code>Normal[raw[All, "County"]] // Length
</code>

50247

while there are only 3141 actual counties listed:

<code>Normal[raw[All, "County"]] // Union // Length    
</code>

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

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

{108.124, Null}

And almost no time on interpreting dataset:

<code>data = raw /. countyRULEs; // AbsoluteTiming
data
</code>

{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:

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

{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.

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

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

enter image description here

Year 1999: a specific year GiS plot

<code>GeoRegionValuePlot[

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

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

Making animation

<code>frames = ParallelTable[
   GeoRegionValuePlot[

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

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

Making legend

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

Growth of death rates ranges vs time

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

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

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

Leave a Reply

Your email address will not be published. Required fields are marked *