Group Abstract

Message Boards

WOLFRAM COMMUNITY

14.4K Views

4 Replies

25 Total Likes

View groups...

Follow this post

Share this post:

GROUPS:

Visualizing Hawaii Seismic Activity with EarthquakeData

Null Null

Posted 7 years ago

If you've been following the news, you've probably seen that the Kilauea volcano in Hawaii has erupted, and there have been reports of many earthquakes. I thought I'd use the built-in EarthquakeData in the Wolfram Language to see if I could come up with any interesting visualizations to explore the seismic activity. I'm going to be using some very basic examples from the documentation. Let's first grab some data from 5/1/18 to 5/6/18 and plot locations. data = EarthquakeData[ Entity["AdministrativeDivision", {"Hawaii", "UnitedStates"}], 4, {{2018, 5, 1}, {2018, 5, 6}}, "Position"]["Values"]; GeoGraphics[{GeoStyling["ReliefMap", MaxPlotPoints -> 300], Red, data /. GeoPosition[{x_, y_}] :> Point[{y, x}]}] Wolfram Language returned a message indicating there were duplicates, so some values were combined. Let's use an example from the documentation and examine earthquake depth. data2 = {#["Position"], #["Depth"]} & /@ Values[EarthquakeData[ Polygon[Entity[ "AdministrativeDivision", {"Hawaii", "UnitedStates"}]], 4, {{2018, 5, 1}, {2018, 5, 6}}]]; Graphics3D[{Opacity[0.6], Map[Append[Reverse[#], 0] &, EntityValue[ Entity["AdministrativeDivision", {"Hawaii", "UnitedStates"}], "Polygon"] /. GeoPosition -> Identity, {-2}], Red, Opacity[1], Line[{Append[Reverse[First[#1]], 0], Append[Reverse[First[#1]], -QuantityMagnitude[#2]/10]} & @@@ data2]}, Axes -> True] Pretty impressive for just using some basic examples from the documentation. I'm not an expert in programming, data visualization or geocomputation, so I'm curious what some of you might be able to come up with! Attachments:

POSTED BY: Null Null

4 Replies

Sort By:

Henrik Schachner

Henrik Schachner, Radiation Therapy Center, Weilheim, Germany

Posted 7 years ago

@Kuba Podkalicki : This is awesome - thanks for sharing! Nice idea to use `Texture`! Regards -- Henrik

POSTED BY: Henrik Schachner

Kuba Podkalicki

Posted 7 years ago

@Henrik, here you go: $textureGeoZoomLevel = 10; $elevationGeoZoomLevel = 7; $area = {Transparent, GeoCircle[Entity["Volcano", "Kilauea"], Quantity[100, "Kilometers"]]}; elevationData = GeoElevationData[$area, "Geodetic", "GeoPosition", GeoZoomLevel -> $elevationGeoZoomLevel] geoBounds = elevationData // Point // GeoBounds eqData = EarthquakeData[$area[[2, 1]], 4, {{2018, 5, 1}, {2018, 5, 10}}]; texture = GeoGraphics[{$area, Point[#Position & /@ eqData]}, GeoRangePadding -> None, GeoRange -> geoBounds, GeoProjection -> "Mercator", GeoServer -> "http://tile.stamen.com/terrain/`1`/`2`/`3`.jpg", GeoZoomLevel -> $textureGeoZoomLevel, ImageSize -> 800 ]; eqPrim = Module[{pos, scaledMag}, pos = Append[{#2, #} & @@ #Position[[1]], -QuantityMagnitude[#Depth, "Meters"]]; scaledMag = Rescale[#Magnitude, {4, 7}]; {Thick, Blend["TemperatureMap", scaledMag], Tooltip[HalfLine[pos, {0, 0, 1}], Dataset@#], AbsolutePointSize[20 scaledMag], Point[pos]} ] & /@ Values[eqData]; Show[ ListPlot3D[{#2, #, #3} & @@@ Catenate@First@elevationData, PlotStyle -> Texture@SetAlphaChannel[Image@texture, .8], Lighting -> "Neutral", ImageSize -> 800, MeshFunctions -> {#3 &}, Background -> Black, SphericalRegion -> True ], Graphics3D@eqPrim, PlotRange -> All ]

@Henrik, here you go:

enter image description here

$textureGeoZoomLevel = 10;
$elevationGeoZoomLevel = 7;

$area = {Transparent,    GeoCircle[Entity["Volcano", "Kilauea"],    Quantity[100, "Kilometers"]]};

elevationData =    GeoElevationData[$area, "Geodetic", "GeoPosition", 
  GeoZoomLevel -> $elevationGeoZoomLevel]

geoBounds = elevationData // Point // GeoBounds

eqData = EarthquakeData[$area[[2, 1]],   4, {{2018, 5, 1}, {2018, 5, 10}}];

texture = GeoGraphics[{$area, Point[#Position & /@ eqData]},
   GeoRangePadding -> None,
   GeoRange -> geoBounds,
   GeoProjection -> "Mercator",
   GeoServer -> "http://tile.stamen.com/terrain/`1`/`2`/`3`.jpg",
   GeoZoomLevel -> $textureGeoZoomLevel,
   ImageSize -> 800
 ];

eqPrim = Module[{pos, scaledMag},
     pos =       Append[{#2, #} & @@ #Position[[1]], -QuantityMagnitude[#Depth,         "Meters"]];
     scaledMag = Rescale[#Magnitude, {4, 7}];
     {Thick, Blend["TemperatureMap", scaledMag], 
      Tooltip[HalfLine[pos, {0, 0, 1}], Dataset@#], 
      AbsolutePointSize[20 scaledMag], Point[pos]}
 ] & /@ Values[eqData];

Show[
 ListPlot3D[{#2, #, #3} & @@@ Catenate@First@elevationData,
  PlotStyle -> Texture@SetAlphaChannel[Image@texture, .8],
  Lighting -> "Neutral",
  ImageSize -> 800,
  MeshFunctions -> {#3 &},
  Background -> Black,
  SphericalRegion -> True
  ],
 Graphics3D@eqPrim,
 PlotRange -> All
]

enter image description here