Model of a Flu Epidemic

Ed Pegg Jr., Wolfram Research

Initialization

RasterGraphics[state_, dim_] := 
        Graphics[
          Raster[Reverse[state], 
            ColorFunction -> (If[EvenQ[#1], Hue[0, 0, 1 - #(1/120)], 
                    Hue[0, #1/120, 1]] &), 
            ColorFunctionScaling -> False], 
          AspectRatio -> Automatic, 
          PlotRange -> {{0, 
                dim[[1]]}, {0, 
                dim[[2]]}}, 
          ImageSize -> dim + 1];
ApplyColorScheme[
          matrix_] := RasterGraphics[#,  Reverse[Dimensions[#]]] &[
          matrix];

North America Population Data

Epidemics

The Kermack-McKendrick model (Susceptibles -> Infectives -> Removals)

Code

Initial conditions

L00Suscept  = 
        Reverse[NorthAmericaPopulationData];
L01Infectd  =  Table[0, {421}, {681}];
L02Removed =  Table[0, {421}, {681}];
L03Picture  =  
        Map[2 Round[4 Log[# + 1]] &, 
          L00Suscept, {2}];
L04Outbreak  =  
        Table[0, {421}, {681}];
L01Infectd[[210, 340]]  =  
        5;   
L04Outbreak[[210, 340]]  =  1;
Airports  =  0;

Show[ApplyColorScheme[L03Picture]];

From here on out, it's the same code, repeated.  Takes about 2 minutes to run.

Do[
L04Outbreak  =  
        Last[CellularAutomaton[{1022, {2, 1}, {1, 1}}, L04Outbreak, 1]] *
          Sign[L03Picture  -  
              Map[Min, 
                Transpose[{L03Picture, 
                    Table[Random[Integer, {0, 200}], {421}, {681}]}, {3, 1, 
                    2}], {2}]]; 
L01Infectd  =  
        Map[Max, 
          Transpose[{L04Outbreak, L01Infectd}, {3, 1, 
              2}], {2}]; 
L01Infectd   =  
        Map[Min, 
            Transpose[{L00Suscept, 3 L01Infectd}, {3, 1, 2}], {2}]  +  
          L01Infectd; 
L04Outbreak  =  
        Sign[L01Infectd  +  
            If[Airports == 1, 
              Map[If[# > 86, If[Random[] <  .02, 1, 0], 0]  &, 
                L03Picture, {2}], 0]]; 
If[
        Airports  ==  0, 
        If[Max[L04Outbreak L03Picture] > 86, 
          Airports = 1]]; 
L00Suscept  =  
        Map[Max[#, 0] &, 
          L00Suscept  -  
            L01Infectd, {2}]; 
L03Picture  =   Map[
          If[Last[#] == 0, 2 Round[4 Log[First[#] + 1]], 
              2 Round[4 Log[Last[#] + 1]] - 1]  &, 
          Transpose[{L00Suscept, L01Infectd}, {3, 1, 
              2}], {2}];
, {4}]

Show[ApplyColorScheme[L03Picture]];

Do[
L04Outbreak  =  
        Last[CellularAutomaton[{1022, {2, 1}, {1, 1}}, L04Outbreak, 1]] *
          Sign[L03Picture  -  
              Map[Min, 
                Transpose[{L03Picture, 
                    Table[Random[Integer, {0, 200}], {421}, {681}]}, {3, 1, 
                    2}], {2}]]; 
L01Infectd  =  
        Map[Max, 
          Transpose[{L04Outbreak, L01Infectd}, {3, 1, 
              2}], {2}]; 
L01Infectd   =  
        Map[Min, 
            Transpose[{L00Suscept, 3 L01Infectd}, {3, 1, 2}], {2}]  +  
          L01Infectd; 
L04Outbreak  =  
        Sign[L01Infectd  +  
            If[Airports == 1, 
              Map[If[# > 86, If[Random[] <  .02, 1, 0], 0]  &, 
                L03Picture, {2}], 0]]; 
If[
        Airports  ==  0, 
        If[Max[L04Outbreak L03Picture] > 86, 
          Airports = 1]]; 
L00Suscept  =  
        Map[Max[#, 0] &, 
          L00Suscept  -  
            L01Infectd, {2}]; 
L03Picture  =   Map[
          If[Last[#] == 0, 2 Round[4 Log[First[#] + 1]], 
              2 Round[4 Log[Last[#] + 1]] - 1]  &, 
          Transpose[{L00Suscept, L01Infectd}, {3, 1, 
              2}], {2}];
, {4}]

Show[ApplyColorScheme[L03Picture]];

Do[
L04Outbreak  =  
        Last[CellularAutomaton[{1022, {2, 1}, {1, 1}}, L04Outbreak, 1]] *
          Sign[L03Picture  -  
              Map[Min, 
                Transpose[{L03Picture, 
                    Table[Random[Integer, {0, 200}], {421}, {681}]}, {3, 1, 
                    2}], {2}]]; 
L01Infectd  =  
        Map[Max, 
          Transpose[{L04Outbreak, L01Infectd}, {3, 1, 
              2}], {2}]; 
L01Infectd   =  
        Map[Min, 
            Transpose[{L00Suscept, 3 L01Infectd}, {3, 1, 2}], {2}]  +  
          L01Infectd; 
L04Outbreak  =  
        Sign[L01Infectd  +  
            If[Airports == 1, 
              Map[If[# > 86, If[Random[] <  .02, 1, 0], 0]  &, 
                L03Picture, {2}], 0]]; 
If[
        Airports  ==  0, 
        If[Max[L04Outbreak L03Picture] > 86, 
          Airports = 1]]; 
L00Suscept  =  
        Map[Max[#, 0] &, 
          L00Suscept  -  
            L01Infectd, {2}]; 
L03Picture  =   Map[
          If[Last[#] == 0, 2 Round[4 Log[First[#] + 1]], 
              2 Round[4 Log[Last[#] + 1]] - 1]  &, 
          Transpose[{L00Suscept, L01Infectd}, {3, 1, 
              2}], {2}];
, {4}]

Show[ApplyColorScheme[L03Picture]];

Do[
L04Outbreak  =  
        Last[CellularAutomaton[{1022, {2, 1}, {1, 1}}, L04Outbreak, 1]] *
          Sign[L03Picture  -  
              Map[Min, 
                Transpose[{L03Picture, 
                    Table[Random[Integer, {0, 200}], {421}, {681}]}, {3, 1, 
                    2}], {2}]]; 
L01Infectd  =  
        Map[Max, 
          Transpose[{L04Outbreak, L01Infectd}, {3, 1, 
              2}], {2}]; 
L01Infectd   =  
        Map[Min, 
            Transpose[{L00Suscept, 3 L01Infectd}, {3, 1, 2}], {2}]  +  
          L01Infectd; 
L04Outbreak  =  
        Sign[L01Infectd  +  
            If[Airports == 1, 
              Map[If[# > 86, If[Random[] <  .02, 1, 0], 0]  &, 
                L03Picture, {2}], 0]]; 
If[
        Airports  ==  0, 
        If[Max[L04Outbreak L03Picture] > 86, 
          Airports = 1]]; 
L00Suscept  =  
        Map[Max[#, 0] &, 
          L00Suscept  -  
            L01Infectd, {2}]; 
L03Picture  =   Map[
          If[Last[#] == 0, 2 Round[4 Log[First[#] + 1]], 
              2 Round[4 Log[Last[#] + 1]] - 1]  &, 
          Transpose[{L00Suscept, L01Infectd}, {3, 1, 
              2}], {2}];
, {4}]

Show[ApplyColorScheme[L03Picture]];

Do[
L04Outbreak  =  
        Last[CellularAutomaton[{1022, {2, 1}, {1, 1}}, L04Outbreak, 1]] *
          Sign[L03Picture  -  
              Map[Min, 
                Transpose[{L03Picture, 
                    Table[Random[Integer, {0, 200}], {421}, {681}]}, {3, 1, 
                    2}], {2}]]; 
L01Infectd  =  
        Map[Max, 
          Transpose[{L04Outbreak, L01Infectd}, {3, 1, 
              2}], {2}]; 
L01Infectd   =  
        Map[Min, 
            Transpose[{L00Suscept, 3 L01Infectd}, {3, 1, 2}], {2}]  +  
          L01Infectd; 
L04Outbreak  =  
        Sign[L01Infectd  +  
            If[Airports == 1, 
              Map[If[# > 86, If[Random[] <  .02, 1, 0], 0]  &, 
                L03Picture, {2}], 0]]; 
If[
        Airports  ==  0, 
        If[Max[L04Outbreak L03Picture] > 86, 
          Airports = 1]]; 
L00Suscept  =  
        Map[Max[#, 0] &, 
          L00Suscept  -  
            L01Infectd, {2}]; 
L03Picture  =   Map[
          If[Last[#] == 0, 2 Round[4 Log[First[#] + 1]], 
              2 Round[4 Log[Last[#] + 1]] - 1]  &, 
          Transpose[{L00Suscept, L01Infectd}, {3, 1, 
              2}], {2}];
, {4}]

Show[ApplyColorScheme[L03Picture]];

Do[
L04Outbreak  =  
        Last[CellularAutomaton[{1022, {2, 1}, {1, 1}}, L04Outbreak, 1]] *
          Sign[L03Picture  -  
              Map[Min, 
                Transpose[{L03Picture, 
                    Table[Random[Integer, {0, 200}], {421}, {681}]}, {3, 1, 
                    2}], {2}]]; 
L01Infectd  =  
        Map[Max, 
          Transpose[{L04Outbreak, L01Infectd}, {3, 1, 
              2}], {2}]; 
L01Infectd   =  
        Map[Min, 
            Transpose[{L00Suscept, 3 L01Infectd}, {3, 1, 2}], {2}]  +  
          L01Infectd; 
L04Outbreak  =  
        Sign[L01Infectd  +  
            If[Airports == 1, 
              Map[If[# > 86, If[Random[] <  .02, 1, 0], 0]  &, 
                L03Picture, {2}], 0]]; 
If[
        Airports  ==  0, 
        If[Max[L04Outbreak L03Picture] > 86, 
          Airports = 1]]; 
L00Suscept  =  
        Map[Max[#, 0] &, 
          L00Suscept  -  
            L01Infectd, {2}]; 
L03Picture  =   Map[
          If[Last[#] == 0, 2 Round[4 Log[First[#] + 1]], 
              2 Round[4 Log[Last[#] + 1]] - 1]  &, 
          Transpose[{L00Suscept, L01Infectd}, {3, 1, 
              2}], {2}];
, {4}]

Show[ApplyColorScheme[L03Picture]];