https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Earth Science sorted by most likes. https://community.wolfram.com/groups/-/m/t/463721 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4902Hero.gif&userId=20103 [2]: https://www.wolframcloud.com/obj/5838919a-e64d-49fe-9193-c6ce123184f2 Marco Thiel 2015-03-21T01:18:08Z https://community.wolfram.com/groups/-/m/t/1072478 Large amounts of data become evermore available - often these datasets are very valuable and difficult to access. In this post I will show how to use air traffic data to generate visualisations like this one. ![enter image description here][1] On the website [http://www.flightradar24.com][2] one can find live flight information of most of the civil air traffic. A great amount of information on all current flights is being made available, such as position and altitude, call sign, type of plane, origin and destination and many more. There are different [subscription plans][3] with different features. The largest business plan even allows you to commercially use the data or use them for public display. Alternatively, you can contribute data https://www.flightradar24.com/add-coverage. This can be done with a tiny RTL-SDR receiver, such as [this one][4]. The setup is quite straight forward; I am usually working on Macs on which I had trouble making this work. On a Windows machine (which I only got for this purpose), the setup is quick. The software for sharing your data can be downloaded from [flightradar24's website][5]. You will also need a driver for the SDR stick, which you can download [from here][6]. You should make sure that you have a good visibility of the sky and that the computer and internet connection are stable. I had to use a Windows 8/Windows 10 machine. It was quite annoying that the machine routinely reboots for software updates. If you want uninterrupted monitoring you will have to deactivate this feature. I have no experience with Windows so this was more complicated than I expected. I found a nice set of [instructions here][7]. Once all of this is done and you donate your data, you will automatically upgraded to the Business plan and will have access to a very rich dataset. You will, for example, be allowed to download up to 1000 csv files per month with detailed tracking information of flights in the database. There is much more data available and using the Wolfram Language to analyse it seems to be quite natural. First explorations ------------------ I download data for a flight from Frankfurt to Aberdeen in csv format. Each row contains a time stamp, date and time of the entry, the callsign, the position (as a string), altitude, speed and direction. I can import the data and then plot it: flightdata = Import["/Users/thiel/Desktop/Flight_LH971_(cb294d1).csv"]; GeoGraphics[{Red, Thick, GeoPath@(ToExpression[#] & /@ Flatten[StringSplit[#, ","] & /@ flightdata[[2 ;;, {4}]], 1])}] ![enter image description here][8] I needed to use StringSplit, because the GPS coordinates come in the form of a single string. Next, I can plot the path in 3D. I can clean the data to get it into the right format: flightphs = {Join[ToExpression[StringSplit[#[[1]], ","]], {ToExpression[#[[2]]]}],ToExpression[#[[3]]]} & /@ flightdata[[2 ;;, {4, 5, 6}]]; Graphics3D[{Red, Thick, Line[{#[[1]], #[[2]], #[[3]]/30000.} & /@ flightphs[[All, 1]]]}] ![enter image description here][9] The 30000 that I use to divide the altitude is just a scaling factor. (Note that the altitude value comes in feet.) We can now join the flight path to one of Mathematica's maps: Show[Graphics3D[{Red, Thick, Line[{#[[1]], #[[2]], -#[[3]]/30000.} & /@ flightphs[[All, 1]]]}, Lighting -> {{"Ambient", White}}], Graphics3D[{Texture[Image[GeoGraphics[GeoPath[GeoPosition[flightphs[[All, 1]]]]]]], Polygon[(PadRight[#, 3] & /@ Tuples[GeoBounds[GeoPath@GeoPosition[flightphs[[All, 1]]], Scaled[0.05]]])[[{1, 2, 4, 3}]], VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}}]}], ImageSize -> Full] ![enter image description here][10] It also looks nice on a satellite image background: Show[Graphics3D[{Red, Thickness[0.005], Line[{#[[1]], #[[2]], -#[[3]]/30000.} & /@ flightphs[[All, 1]]]}, Lighting -> {{"Ambient", White}}], Graphics3D[{Texture[Image[GeoGraphics[{Opacity[0], GeoPath[GeoPosition[flightphs[[All, 1]]]]}, GeoBackground -> "Satellite"]]], Polygon[(PadRight[#, 3] & /@ Tuples[GeoBounds[GeoPath@GeoPosition[flightphs[[All, 1]]], Scaled[0.05]]])[[{1, 2, 4, 3}]], VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}}]}], ImageSize -> Full] ![enter image description here][11] Multiple flights ---------------- Next, I download 10 trajectories of the flight LH971 from Frankfurt to Aberdeen. FileNames["*", "/Users/thiel/Desktop/Aberdeen LH971/"] ![enter image description here][12] I then import all of the trajectories: flightdataall = Import /@ FileNames["*", "/Users/thiel/Desktop/Aberdeen LH971/"]; This corresponds to 282 entries - each consisting of time stamp, date and time of the entry, the callsign, the position (as a string), altitude, speed and direction. I can clean them all up flightphsall = ({Join[ToExpression[StringSplit[#[[1]], ","]], {ToExpression[#[[2]]]}], ToExpression[#[[3]]]} & /@ #[[2 ;;, {4, 5, 6}]] &) /@ flightdataall; and then plot them together: Show[Graphics3D[{Red, Thickness[0.004], Line[{#[[1]], #[[2]], -#[[3]]/30000.} & /@ #[[All, 1]] & /@ flightphsall]}, Lighting -> {{"Ambient", White}}, ViewPoint -> {-10.`, 5.`, -5.`}, ViewVertical -> {0.8924410944866072`, -0.23945064940819427`, -7.766116131708949`}], Graphics3D[{Texture[Image[GeoGraphics[{Opacity[0], GeoPath[GeoPosition[flightphs[[All, 1]]]]}, GeoBackground -> "Satellite", GeoRange -> {{Min[#[[All, 1, 1]]], Max[#[[All, 1, 2]]]}, {Min[#[[All, 2, 1]]], Max[#[[All, 2, 2]]]}} & @(GeoBounds[GeoPath@GeoPosition[#[[All, 1]]], Scaled[0.05]] & /@ flightphsall)]]], Polygon[(PadRight[#, 3] & /@ Tuples[{{Min[#[[All, 1, 1]]], Max[#[[All, 1, 2]]]}, {Min[#[[All, 2, 1]]], Max[#[[All, 2, 2]]]}} & @(GeoBounds[ GeoPath@GeoPosition[#[[All, 1]]], Scaled[0.05]] & /@ flightphsall)])[[{1, 2, 4, 3}]], VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}}]}], ImageSize -> Full] ![enter image description here][13] Note that I use ViewPoint and ViewVertical options. This is because without them, the orientation of the resulting 3D graphic is not optimal. So I plotted the image without the additional options and then rotated it until I was happy with the orientation. Then I use the function extractViewPos[img_] := Flatten[Union[Extract[img, Position[img, #]] & /@ {ViewPoint -> _, ViewCenter -> _, ViewVertical -> _, ViewAngle -> _,ViewVector -> _, ViewRange -> _}]]; Just copy the image into the square brackets and execute: extractViewPos[-Graphic goes here-] and get {ViewPoint -> {-10., 5., -5.}, ViewVertical -> {0.892441, -0.239451, -7.76612}} This is not my function, but I found it online and have been using it ever since. Animating a flight ------------------ Now we can mark the position of the aeroplane by a sphere and animate the flight: backround3D2 = Show[Graphics3D[{Red, Thick, Line[{#[[1]], #[[2]], -#[[3]]/30000.} & /@ flightphs[[All, 1]]]},Lighting -> {{"Ambient", White}}, ViewPoint -> {-10.`, 5.`, -5.`}, ViewVertical -> {0.8924410944866072`, -0.23945064940819427`, -7.766116131708949`}], Graphics3D[{Texture[Image[GeoGraphics[{Opacity[0], GeoPath[GeoPosition[flightphs[[All, 1]]]]}, GeoBackground -> "Satellite"]]], Polygon[(PadRight[#, 3] & /@ Tuples[GeoBounds[GeoPath@GeoPosition[flightphs[[All, 1]]], Scaled[0.05]]])[[{1, 2, 4, 3}]], VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}}]}],ImageSize -> Full]; Manipulate[ Show[Graphics3D[{Red, Sphere[{#[[1]], #[[2]], -#[[3]]/30000.} & @flightphs[[k, 1]], 0.1]}, ViewPoint -> {-10.`, 5.`, -5.`}, ViewVertical -> {0.8924410944866072`, -0.23945064940819427`, -7.766116131708949`}, ImageSize -> Full], backround3D2], {k, 1, Length[flightphs],5}] ![enter image description here][14] The multiple flights I have displayed above are the same route but executed by different aeroplanes. Later we will follow individual aeroplanes. But first we will look at the peculiar take-off and landing patterns. Take-off and landing patterns ----------------------------- When we look at the take-off and touch-down times we observe that there are two main directions for both starting and destination airports. What decides which direction the planes are taking? Graphics3D[{Red, Thickness[0.004], Line[{#[[1]], #[[2]], -#[[3]]/30000.} & /@ #[[All, 1]] & /@ flightphsall]}, Lighting -> {{"Ambient", White}}, ViewPoint -> {-10.`, 5.`, -5.`}, ViewVertical -> {0.8924410944866072`, -0.23945064940819427`, -7.766116131708949`}] ![enter image description here][15] We first need to determine the wind direction in Frankfurt and Aberdeen on days with either of the two take-off/landing directions. First for Frankfurt. frankfurttimeheading = Table[Select[flightdataall[[k]], #[[5]] > 4000 &][[1, {1, -1}]], {k, 1, 10}] which gives {{1488564623, 69}, {1488650932, 250}, {1488737193, 250}, {1488823517, 249}, {1488909842, 250}, {1488996665, 249}, {1489080927, 250}, {1489168646, 250}, {1489254863, 69}, {1489341257, 69}} We see that there are two clusters, one at around 69 degrees and one at around 250 degrees: fdates69 = FromUnixTime /@ Select[frankfurttimeheading, #[[2]] < 100 &][[All, 1]]; fdates250 = FromUnixTime /@ Select[frankfurttimeheading, #[[2]] > 100 &][[All, 1]]; The Wolfram Language knows the wind directions for those days: WindDirectionData[Entity["Airport", "EDDF"], fdates69] (*{Quantity[60., "AngularDegrees"], Quantity[70., "AngularDegrees"], Quantity[70., "AngularDegrees"]}*) and WindDirectionData[Entity["Airport", "EDDF"], fdates250] {Quantity[250., "AngularDegrees"], Quantity[170., "AngularDegrees"], Quantity[-60., "AngularDegrees"], Quantity[210., "AngularDegrees"], Quantity[200., "AngularDegrees"], Quantity[-70., "AngularDegrees"], Quantity[70., "AngularDegrees"]} It knows the wind vector data; here we plot it for the two situations. Graphics[Arrow[{{0, 0}, #}] & /@ QuantityMagnitude[WindVectorData[Entity["Airport", "EDDF"], fdates250]]] ![enter image description here][16] Graphics[Arrow[{{0, 0}, #}] & /@ QuantityMagnitude[WindVectorData[Entity["Airport", "EDDF"], fdates69]]] ![enter image description here][17] If we now average the data Show[Graphics[{Red, Thick, Arrow[{{0, 0}, Mean[QuantityMagnitude[WindVectorData[Entity["Airport", "EDDF"], fdates250]]]}]}], Graphics[{Green, Thick, Arrow[{{0, 0}, Mean[QuantityMagnitude[WindVectorData[Entity["Airport", "EDDF"], fdates69]]]}]}]] ![enter image description here][18] We see that the wind direction seems to correlate with the take off direction at least for relatively strong winds. This is in agreement with [general advice of how to choose the runway][19]. We can now do the same for Aberdeen. aberdeentimeheading = Table[Select[Reverse[flightdataall[[k]]], #[[5]] > 4000 &][[1, {1, -1}]], {k, 1, 10}]; We split the dates into two groups: smaller and larger than 200 degrees. adates230 = FromUnixTime /@ Select[frankfurttimeheading, #[[2]] > 200 &][[All, 1]]; adates169 = FromUnixTime /@ Select[frankfurttimeheading, #[[2]] < 200 &][[All, 1]]; These are the respective vectors: Graphics[Arrow[{{0, 0}, #}] & /@ QuantityMagnitude[WindVectorData[Entity["City", {"Dundee", "DundeeCity", "UnitedKingdom"}], adates169]]] ![enter image description here][20] Graphics[Arrow[{{0, 0}, #}] & /@ QuantityMagnitude[WindVectorData[Entity["City", {"Dundee", "DundeeCity", "UnitedKingdom"}], adates230]]] ![enter image description here][21] Now we can plot this for the different averaged directions. Show[Graphics[{Red, Thick, Arrow[{{0, 0}, -Mean[QuantityMagnitude[WindVectorData[Entity["City", {"Dundee", "DundeeCity", "UnitedKingdom"}],adates169]]]}]}], Graphics[{Green, Thick, Arrow[{{0, 0}, -Mean[QuantityMagnitude[WindVectorData[Entity["City", {"Dundee", "DundeeCity", "UnitedKingdom"}],adates230]]]}]}]] ![enter image description here][22] The pattern here is not so clear. This could be because of low wind speeds. Following individual aeroplanes (short haul) -------------------------------------------- We can also follow an individual aeroplane (D-EACB) for, say, one month or so. Download the data and check that they are there: FileNames["*", "/Users/thiel/Desktop/D-EACB/"] ![enter image description here][23] Import the data and plot everything: flightdataDEACB = Import /@ FileNames["*", "/Users/thiel/Desktop/D-EACB/"]; GeoGraphics[{Red, Thick, GeoPath@(ToExpression[#] & /@ Flatten[StringSplit[#, ","] & /@ #, 1]) & /@ flightdataDEACB[[All, 2 ;;]][[All, All, {4}]]}] ![enter image description here][24] Of course, the same thing in 3D looks somewhat more impressive: flightphsDEACB = ({Join[ ToExpression[ StringSplit[#[[1]], ","]], {ToExpression[#[[2]]]}], ToExpression[#[[3]]]} & /@ #[[2 ;;, {4, 5, 6}]] &) /@ flightdataDEACB; Show[Graphics3D[{Red, Thickness[0.004], Line[{#[[1]], #[[2]], -#[[3]]/30000.} & /@ #[[All, 1]] & /@ flightphsDEACB]}, Lighting -> {{"Ambient", White}}, ViewPoint -> {-10.`, 5.`, -5.`}, ViewVertical -> {0.8924410944866072`, -0.23945064940819427`, \ -7.766116131708949`}], Graphics3D[{Texture[ Image[GeoGraphics[{Opacity[0], GeoPath@(ToExpression[#] & /@ Flatten[StringSplit[#, ","] & /@ flightdataDEACBjoin[[All, {4}]], 1])}, GeoBackground -> "Satellite", GeoRange -> {{Min[#[[All, 1, 1]]], Max[#[[All, 1, 2]]]}, {Min[#[[All, 2, 1]]], Max[#[[All, 2, 2]]]}} & @(GeoBounds[ GeoPath@GeoPosition[#[[All, 1]]], Scaled[0.05]] & /@ flightphsDEACB), GeoProjection -> "Equirectangular"]]], Polygon[(PadRight[#, 3] & /@ Tuples[{{Min[#[[All, 1, 1]]], Max[#[[All, 1, 2]]]}, {Min[#[[All, 2, 1]]], Max[#[[All, 2, 2]]]}} & @(GeoBounds[ GeoPath@GeoPosition[#[[All, 1]]], Scaled[0.05]] & /@ flightphsDEACB)])[[{1, 2, 4, 3}]], VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}}]}], ImageSize -> Full] ![enter image description here][25] Following individual aeroplanes (long haul) ------------------------------------------- All these flights are relatively short distance. I next choose a airbus A380 and look at its movements over a month or so. flightdataGXLED = Import /@ FileNames["*", "/Users/thiel/Desktop/G-XLED/"]; GeoGraphics[{Red, Thick, GeoPath@(ToExpression[#] & /@ Flatten[StringSplit[#, ","] & /@ #, 1]) & /@ flightdataGXLED[[All, 2 ;;]][[All, All, {4}]]}, ImageSize -> Full] ![enter image description here][26] Again a 3D representation makes the flight paths come out much better. First we prepare the data: flightdataGXLEDjoin = Flatten[Select[flightdataGXLED[[All, 2 ;;]], Head[#] > 0 &], 1]; flightphsGXLED = Select[({Join[ToExpression[StringSplit[#[[1]], ","]], {ToExpression[#[[2]]]}], ToExpression[#[[3]]]} & /@ #[[2 ;;, {4, 5, 6}]] &) /@ flightdataGXLED, Length[#] > 0 &]; Then we plot: Show[Graphics3D[{Red, Thickness[0.002], Line[{#[[1]], #[[2]], -#[[3]]/3000.} & /@ #[[All, 1]] & /@ flightphsGXLED]}, Lighting -> {{"Ambient", White}}, ViewPoint -> {-10.67632349817987`, 3.7276615038423772`, -4.664042818603161`}, ViewVertical -> {0.11539873519013898`, -0.022518333742098193`, -0.9930639740530294`}, ImagePadding -> None], Graphics3D[{Texture[Image[GeoGraphics[{Opacity[0], GeoPath@(ToExpression[#] & /@ Flatten[StringSplit[#, ","] & /@ flightdataGXLEDjoin[[All, {4}]], 1])}, GeoBackground -> "Satellite", GeoRange -> {{Min[#[[All, 1, 1]]], Max[#[[All, 1, 2]]]}, {Min[#[[All, 2, 1]]], Max[#[[All, 2, 2]]]}} & @(GeoBounds[GeoPath@GeoPosition[#[[All, 1]]], Scaled[0.05]] & /@ flightphsGXLED), GeoProjection -> "Equirectangular", ImagePadding -> None]]], Polygon[(PadRight[#, 3] & /@ Tuples[{{Min[#[[All, 1, 1]]], Max[#[[All, 1, 2]]]}, {Min[#[[All, 2, 1]]], Max[#[[All, 2, 2]]]}} & @(GeoBounds[GeoPath@GeoPosition[#[[All, 1]]], Scaled[0.05]] & /@ flightphsGXLED)])[[{1, 2, 4, 3}]], VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}}]}], ImageSize -> Full, ImagePadding -> None] ![enter image description here][27] Representing the flight paths on a sphere ----------------------------------------- Note that I had to use the Equirectangular projection. Of course, particularly when looking at these long distances it would be more appropriate to represent the Earth as a sphere. We need to convert the coordinates and rescale the altitudes. toCoordinates[coords_] := FromSphericalCoordinates[{#[[1]], Pi/2 - #[[2]], Mod[Pi + #[[3]], 2 Pi, -Pi]}] & /@ (Flatten[{1., #/360*2 Pi}] & /@ coords) lengths[inputdata_] := 2.*(inputdata/Max[inputdata]) The representation of the path is somewhat related to [another representation I posted on this community][28]. myFlightPath[data_, radius_, scale_] := Show[SphericalPlot3D[radius, {u, 0, Pi}, {v, 0, 2 Pi}, Mesh -> None, TextureCoordinateFunction -> ({#5, 1 - #4} &), PlotStyle -> Directive[Specularity[White, 10], Texture[Import["~/Desktop/backgroundimage.gif"]]], Lighting -> "Neutral", Axes -> False, RotationAction -> "Clip", Boxed -> False, PlotPoints -> 100, PlotRange -> {{-3, 3}, {-3, 3}, {-3, 3}}, ImageSize -> Full], Graphics3D[Flatten[{Green, Thickness[0.004], Line[(radius + #[[2]]*scale)*#[[1]] & /@ Transpose[{toCoordinates[#[[All, 1]]], lengths[#[[All, 2]]]} &@({#[[1]], 1. #[[2]]} & /@ data)]]}]]] Let's use that to plot one trajectory. flightpath = {ToExpression[StringSplit[#[[4]], ","]], #[[6]]} & /@ flightdataGXLED[[2, 2 ;;]]; myFlightPath[flightpath, 2, 1/3.] ![enter image description here][29] If we want to plot multiple flights we should modify the function slightly. myFlightPathMulti[data_, radius_, scale_] := Show[SphericalPlot3D[radius, {u, 0, Pi}, {v, 0, 2 Pi}, Mesh -> None, TextureCoordinateFunction -> ({#5, 1 - #4} &), PlotStyle -> Directive[Specularity[White, 10], Texture[Import["~/Desktop/backgroundimage.gif"]]], Lighting -> "Neutral", Axes -> False, RotationAction -> "Clip", Boxed -> False, PlotPoints -> 100, PlotRange -> {{-3, 3}, {-3, 3}, {-3, 3}}, ImageSize -> Full], Graphics3D[Flatten[{RandomColor[], Thickness[0.004], Line[(radius + #[[2]]*scale)*#[[1]] & /@ Transpose[{toCoordinates[#[[All, 1]]], lengths[#[[All, 2]]]} &@({#[[1]], 1. #[[2]]} & /@ #)]]}] & /@ data]] Let's prepare the data. flightpathsmult = Join[{{#[[1, 1]], 0.}}, #, {{#[[-1, 1]], 0.}}] & /@ Select[({ToExpression[StringSplit[#[[4]], ","]], #[[6]]} & /@ # & /@ flightdataGXLED[[All, 2 ;;]]), Length[#] > 1 &]; The trajectories seem to come out fine: Graphics3D[ Flatten[{RandomColor[], Thickness[0.01], Line[(2. + #[[2]]*0.3)*#[[1]] & /@ Transpose[{toCoordinates[#[[All, 1]]], lengths[#[[All, 2]]]} &@({#[[1]], 1. #[[2]]} & /@ #)]]}] & /@ flightpathsmult[[1 ;; 10]]] ![enter image description here][30] Note, that there are some "straight lines" in the trajectories. They correspond to a lack of data point over unpopulated areas. Plotting all trajectories on the globe looks like this: myFlightPathMulti[flightpathsmult, 2., 1/3.] ![enter image description here][31] Let's choose a black background: myFlightPathMultiBlack[data_, radius_, scale_] := Show[SphericalPlot3D[radius, {u, 0, Pi}, {v, 0, 2 Pi}, Mesh -> None, TextureCoordinateFunction -> ({#5, 1 - #4} &), PlotStyle -> Directive[Specularity[White, 10], Texture[Import["~/Desktop/backgroundimage.gif"]]], Lighting -> "Neutral", Axes -> False, RotationAction -> "Clip", Boxed -> False, PlotPoints -> 100, PlotRange -> {{-3, 3}, {-3, 3}, {-3, 3}}, ImageSize -> Full, Background -> Black], Graphics3D[Flatten[{RandomColor[], Thickness[0.004], Line[(radius + #[[2]]*scale)*#[[1]] & /@ Transpose[{toCoordinates[#[[All, 1]]], lengths[#[[All, 2]]]} &@({#[[1]], 1. #[[2]]} & /@ #)]]}] & /@ data, Background -> Black]] and plot: myFlightPathMultiBlack[flightpathsmult, 2., 1/3.] ![enter image description here][32] This gives the animation at the beginning of this post. Further Information that we can extract from the data ----------------------------------------------------- We can also use the data to get some information about the usage of aeroplanes. We can take the plane with the call sign D-EACB and check for the percentage of time that it is airborne. We first calculate the time window I have data for: approxTimeWindowDEACB = Differences[{Select[flightdataDEACB[[1]], #[[-3]] > 10 &][[1, 1]], Select[flightdataDEACB[[Length[flightdataDEACB]]], #[[-3]] > 10 &][[-1, 1]]}][[1]] This gives 1046462 and is given in seconds. To compute the (approximate) time the plane is airborne we have to check for altitudes larger than some threshold. approxTimeinAirDEACB = Total[Flatten[Table[Differences@Reverse@Select[flightdataDEACB[[k]], #[[-3]] > 10 &][[All, 1]][[{1, -1}]], {k, 1, Length[flightdataDEACB]}]]] which gives 247835 seconds. Now, we can calculate the respective fraction. N[approxTimeinAirDEACB/approxTimeWindowDEACB] which gives 0.236831. So this is approximately 24% of the time. Given that planes on short haul flights are mostly grounded over night and that they have substantial time at the airports this seems to be reasonable. Let's do the same for the A 380. approxTimeWindowGXLED = Differences[Flatten[Select[Table[Select[Select[flightdataGXLED, Length[#] > 1 &][[k]], #[[-3]] > 10 &], {k, 1, Length[Select[flightdataGXLED, Length[#] > 1 &]]}], Length[#] > 1 &], 1][[{1, -1}, 1]]][[1]] which is 4258510, and approxTimeinAirGXLED = Total[Select[Flatten[Table[If[Length[Select[flightdataGXLED[[k]], #[[-3]] > 10 &][[All, 1]]] > 1, Differences@Reverse@Select[flightdataGXLED[[k]], #[[-3]] > 10 &][[All, 1]][[{1, -1}]]], {k, 1, Length[flightdataGXLED]}]], NumberQ]] which is 2445537. This gives N[approxTimeinAirGXLED/approxTimeWindowGXLED] so about 57%; hence a more efficient aeroplane use. We can now also determine the average speed when the plane is moving. N@Mean[DeleteCases[Flatten[flightdataGXLED[[All, 2 ;;]], 1][[All, 6]],0]] (*366.84*) This is 367 kts or UnitConvert[366.84 Quantity[1, "Knots"], Quantity[1, (("Kilometers")/("Hours"))]] 680 km/h. Note that this is a rather inappropriate estimate, because the data is not necessarily sampled uniformly and especially data from over the oceans might be missing. If we accept that issue we can calculate the histogram of the data: Histogram[DeleteCases[Flatten[flightdataGXLED[[All, 2 ;;]], 1][[All, 6]], 0], Automatic, "PDF", FrameLabel -> {"Speed in kts", "Probablity"}, LabelStyle -> Directive[Bold, 16], ImageSize -> Large, PlotTheme -> "Marketing", ColorFunction -> "TemperatureMap"] ![enter image description here][33] This graphic suggests that the fast speed flight time is vastly underestimated. The maximum speed is Max@DeleteCases[Flatten[flightdataGXLED[[All, 2 ;;]], 1][[All, 6]], 0] (*697*) which is a ground speed of N@UnitConvert[697 Quantity[1, "Knots"], Quantity[1, (("Kilometers")/("Hours"))]] 1290.84 km.h. We can compare this to the speed of sound in air. UnitConvert[ThermodynamicData["Air", "SoundSpeed", {"Temperature" -> Quantity[20, "DegreesCelsius"], "Pressure" -> Quantity[1, "Atmospheres"]}], "Kilometers"/"Hours"] which gives 1236.18 km/h. So the maximum speed is 1290.84/1236.16 104% of the speed of sound, or Mach 1 (at ground level), which is a bit on the high side. Note that the top speed of the A380 is given as 1020 km/h. The peak in the histogram at cruising speed is at around 490 kts which is in fact the maximal speed of the A380 as given in Wikipedia. The higher than expected ground speed might be due to the jet stream - even though speeds of more than Mach 1 seem to be unlikely. There are [some reports of this happening][34] though. This is only a very brief description of what can be achieved with the fantastic data from flightradar24. I encourage everyone to join that community and contribute data. The data provided on that site and the power of the Wolfram Language will allow you to gain insight into what is going on in the skies. Cheers, Marco [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=rotateEarth.gif&userId=48754 [2]: http://www.flightradar24.com [3]: https://www.flightradar24.com/premium/ [4]: https://www.amazon.co.uk/NooElec-Receiver-Compatible-Packages-Guaranteed/dp/B009U7WZCA/ [5]: https://www.flightradar24.com/share-your-data [6]: http://zadig.akeo.ie [7]: http://tunecomp.net/disable-automatic-reboot-after-updates-installation-in-windows-10/ [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at23.11.55.png&userId=48754 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at23.13.06.png&userId=48754 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at23.22.00.png&userId=48754 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Onepathrotate.gif&userId=48754 [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at23.23.18.png&userId=48754 [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at23.26.51.png&userId=48754 [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=AnimatedFlight.gif&userId=48754 [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at23.36.33.png&userId=48754 [16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at23.41.18.png&userId=48754 [17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at23.42.06.png&userId=48754 [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at23.43.12.png&userId=48754 [19]: https://www.ivao.aero/training/documentation/books/PP_ADC_select_runway.pdf [20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at23.45.55.png&userId=48754 [21]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at23.46.44.png&userId=48754 [22]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at23.48.26.png&userId=48754 [23]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at23.49.31.png&userId=48754 [24]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-25at23.59.09.png&userId=48754 [25]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-26at00.00.08.png&userId=48754 [26]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-26at00.01.39.png&userId=48754 [27]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-26at00.05.09.png&userId=48754 [28]: http://community.wolfram.com/groups/-/m/t/905016 [29]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-26at00.08.34.png&userId=48754 [30]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-26at00.11.21.png&userId=48754 [31]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-26at00.12.03.png&userId=48754 [32]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-26at00.13.55.png&userId=48754 [33]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-04-26at00.21.15.png&userId=48754 [34]: http://www.telegraph.co.uk/news/worldnews/northamerica/usa/11337617/Jet-stream-blasts-BA-plane-across-Atlantic-in-record-time.html Marco Thiel 2017-04-25T23:26:29Z https://community.wolfram.com/groups/-/m/t/463610 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/2fb30490-e074-40c2-99f3-80634810ef4d Vitaliy Kaurov 2015-03-20T17:02:11Z https://community.wolfram.com/groups/-/m/t/1671437 ![US County century-scale climate change][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=figmean.jpg&userId=66744 [2]: https://www.wolframcloud.com/obj/440933c0-d91d-4dfc-ac2e-88dd71451744 John Shonder 2019-04-28T15:26:25Z https://community.wolfram.com/groups/-/m/t/551187 Over the summer, I had the opportunity to work with a [Phantom 2 Vision+ drone from DJI][1]. After a few exciting trial flights, I decided to investigate a real world application: fly over one of the abundant Illinois farm fields and record bird's eye images of the crops below. Then using this data, create a simple function to estimate the crop yield for that area. ![enter image description here][2] Recently, I drove out to a farm with a fellow Wolfram employee who also happens to be an expert drone operator. We flew the drone over a stretch of soy fields and took pictures and shot video along the way. Here is a small sample video: [Drone flying over soy field (full video):][3] https://vimeo.com/136947441 [![enter image description here][4]][3] As you can see in the video, most areas of this field is in really good shape (at least when judged from this altitude). But there are some areas near a drainage ditch where the soy is not growing very well. This can happen because the soil is too moist for too long causing the root system to lack oxygen. As a result the soy plants are much smaller near the drainage area or completely missing. Let's look at one particular example of this situation. We import the data from the SD card that was used as storage on the drone: crop = Import["F:\\DCIM\\101MEDIA\\DJI01951.JPG"] ![enter image description here][5] The first thing to notice is the large amount of barrel distortion in this image (note how the road looks highly curved). This is due to the drone camera having very wide angle lens. There is no built-in function in the Wolfram Language to simply correct for barrel distortion (yet), so I am going to focus on a center part of the image where the distortion is not too bad. The ideal situation here would be to fly very high with a very narrow lens. So first, to get a smaller center part of the image, let's take a look at a subimage about 1/3 x 1/3 the size of the original, located a little bit right of the center: {columns, rows} = ImageDimensions[crop]; {rowLow, rowHigh} = {Round[rows/3], Round[2 rows/3]}; {columnLow, columnHigh} = {Round[columns/2], Round[5 columns/6]}; HighlightImage[crop, Rectangle[{columnLow, rowLow}, {columnHigh, rowHigh}], Method -> "Brightness"] ![enter image description here][6] Using this region we can now get a sample of the crop that contains both very healthy plants (on the left) and very small or missing plants (on the right): cropSample = ImageTake[crop, {rowLow, rowHigh}, {columnLow, columnHigh}] ![enter image description here][7] So now the question becomes: how do I measure what fraction of the harvest is lost in this sample? A simple approach is to just turn the image into a black and white image where a white color indicates a bright area (like the green plants) and a black color indicates the soil (dark in the original image): binaryCrop1 = Binarize[cropSample] ![enter image description here][8] That sort of works, but the original sample still had bright areas due to visible rocks and dead leaves, so let's see if we can refine this approach just a little bit. Instead of using just a plain binarize we can look at the dominant color in this image, which we expect to be greens and blacks: dominantColors = DominantColors[cropSample, 10] ![enter image description here][9] The result here is more or less as we would expect, with some additional grays (perhaps from dead leaves and rocks). Now let's take a look at the first dominant color, a good fit for a healthy soy plant in this image. Using this color we can now calculate the color distance for each pixel giving us an image where dark colors are close matches and white colors are poor matches: ColorDistance[cropSample, First[dominantColors]] ![enter image description here][10] Again we can binarize this image. In this case also need to negate the black/white colors to get white/black so the colors in the binarized image have the same meaning as before (white=soy, black=not soy): binaryCrop2 = ColorDistance[cropSample, First[dominantColors]] // Binarize // ColorNegate ![enter image description here][11] This result actually looks quite nice: Areas with no soy plants now have a black pixel values (0) and areas with soy plants have white pixel values (1). So let's count the white pixels: soyPixels = ImageMeasurements[binaryCrop2, "Total"] (* Gives: 954,214.0 *) And also lets count the total number of pixels in the image: totalPixels = Times @@ ImageMeasurements[binaryCrop2, "Dimensions"] (* Gives: 1,603,814 *) And now we have our crude estimate for the amount of soy plants in this image, about 60%: Quantity[100 soyPixels/totalPixels, "Percent"] (* Gives: 59.4966% *) Of course this is a very crude estimation, but perhaps not too far off from the actual yield when this particular spot is harvested. I actually expect this to be a slight overestimation, since smaller plants will likely have no soy beans or less soy beans than a fully grown plant. But I am not a crop analyst, so we'll have to go with 60% for now. Finally, an analysis like this can easily be done on the fly (or "on the drone" in this case), where an embedded system like a Raspberry Pi or similar device can process data as it comes in, and even direct the drone to the areas of highest interest (with the most stressed plants). [1]: http://www.dji.com/product/phantom-2-vision/feature [2]: /c/portal/getImageAttachment?filename=0_0.jpg&userId=11733 [3]: https://vimeo.com/136947441 [4]: /c/portal/getImageAttachment?filename=ezgif-3078374406.gif&userId=11733 [5]: /c/portal/getImageAttachment?filename=Untitled-8.png&userId=22112 [6]: /c/portal/getImageAttachment?filename=Untitled-9.png&userId=22112 [7]: /c/portal/getImageAttachment?filename=Untitled-10.png&userId=22112 [8]: /c/portal/getImageAttachment?filename=Untitled-11.png&userId=22112 [9]: /c/portal/getImageAttachment?filename=Untitled-12.png&userId=22112 [10]: /c/portal/getImageAttachment?filename=Untitled-13.png&userId=22112 [11]: /c/portal/getImageAttachment?filename=Untitled-14.png&userId=22112 Arnoud Buzing 2015-08-21T19:28:02Z https://community.wolfram.com/groups/-/m/t/859842 Yesterday I posted a little [piece of code to visualise the changing mean temperature of the earth][1]. The animation tried to point out "how the temperature spirals out of control". In order to account for positive and negative deviations from the "standard" temperature, we needed to use a transformation from temperature difference to radius. This was non-linear and one might argue that lower temperatures are underrepresented. Here is an alternative attempt. ![enter image description here][2] I do not post it in the same thread as the last post, because the gif is quite large and adding more the original thread might make it very slow to load. In spite of that I only have uploaded a lower quality video with every second frame. You can download the full quality file [from here][3]. Here's the implementation of the new idea, which I have seen in a similar fashion somewhere online: tempdata = Transpose[{Interpreter["Date"][#[[All, 1]]], #[[All, 2]]}] &@ Import["http://www.metoffice.gov.uk/hadobs/hadcrut4/data/current/time_series/HadCRUT.4.4.0.0.monthly_ns_avg.txt", "Data"]; frames2 = Table[ListLinePlot[#, PlotStyle -> Table[Opacity[0.7/(1 + Min[k, Length[Partition[tempdata[[All, 2]], UpTo[12]]]] - j)^2 + 0.3], {j, 1, Min[k, Length[Partition[tempdata[[All, 2]], UpTo[12]]]]}], PlotRange -> {{1, 12}, Evaluate[MinMax[tempdata[[All, 2]]] + {-0.1, 0.1}]}, Frame -> True, Background -> Black, FrameStyle -> Directive[White, Bold, 16], LabelStyle -> Directive[White, Bold, 16], ImageSize -> Large, ColorFunction -> (ColorData["Temperature"][2^(#2) - 0.5] &), ColorFunctionScaling -> False, FrameTicks -> {{True, None}, {Transpose@{Range[12], {"Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}}, None}}, FrameLabel -> {"Month", "\[CapitalDelta]T"}, ImagePadding -> 75, AspectRatio -> 1, Epilog -> {Text[Style[1849 + Min[k, Length[Partition[tempdata[[All, 2]], UpTo[12]]]], Red, 21], {2.5, 1.}]}] & @ Partition[tempdata[[All, 2]], UpTo[12]][[1 ;; Min[k, Length[Partition[tempdata[[All, 2]], UpTo[12]]]]]], {k, 1, Length[Partition[tempdata[[All, 2]], UpTo[12]]] + 10}]; You an list animate it: ListAnimate[frames2] I exported the frames: Monitor[Do[Export["~/Desktop/ClimateGraph/frame" <> ToString[1000 + k] <> ".jpg", frames2[[k]], ImageResolution -> 100], {k, 1, Length[frames2], 1}], k] and use the terminal command: convert -delay 15 -loop 0 frame*.jpg animatedfull.gif to create the animation above. If you prefer the curves a bit smoother you can use: frames3 = Table[ListLinePlot[#, PlotStyle -> Table[Opacity[0.7/(1 + Min[k, Length[Partition[tempdata[[All, 2]], UpTo[12]]]] - j)^2 + 0.3], {j, 1, Min[k, Length[Partition[tempdata[[All, 2]], UpTo[12]]]]}], PlotRange -> {{1, 12}, Evaluate[MinMax[tempdata[[All, 2]]] + {-0.1, 0.1}]}, InterpolationOrder->2, Frame -> True, Background -> Black, FrameStyle -> Directive[White, Bold, 16], LabelStyle -> Directive[White, Bold, 16], ImageSize -> Large, ColorFunction -> (ColorData["Temperature"][2^(#2) - 0.5] &), ColorFunctionScaling -> False, FrameTicks -> {{True, None}, {Transpose@{Range[12], {"Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}}, None}}, FrameLabel -> {"Month", "\[CapitalDelta]T"}, ImagePadding -> 75, AspectRatio -> 1, Epilog -> {Text[Style[1849 + Min[k, Length[Partition[tempdata[[All, 2]], UpTo[12]]]], Red, 21], {2.5, 1.}]}] & @ Partition[tempdata[[All, 2]], UpTo[12]][[1 ;; Min[k, Length[Partition[tempdata[[All, 2]], UpTo[12]]]]]], {k, 1, Length[Partition[tempdata[[All, 2]], UpTo[12]]] + 10}]; And proceed as before. The last frame looks like this: ![enter image description here][4] Cheers, Marco [1]: http://community.wolfram.com/groups/-/m/t/859046 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=9057animated.gif&userId=48754 [3]: https://www.dropbox.com/s/g1xeppsy2wtucln/animatedfull.gif?dl=0 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-05-21at00.59.23.png&userId=48754 Marco Thiel 2016-05-21T00:12:16Z https://community.wolfram.com/groups/-/m/t/1731676 ##Goal of the Project## Analyze and study algorithms for predicting if topography is land or ocean by using simple image processing to find the differences between on-land relief plots and underwater relief plots because there is a difference between simple image processing and machine learning on images ##What is Topography?## Topography is a broad term used to describe the detailed study of the earth's surface. This includes changes in the surface such as mountains and valleys as well as features such as rivers and roads. It can also include the surface of other planets, the moon, asteroids, and meteors. Topography is closely linked to the practice of surveying, which is the practice of determining and recording the position of points in relation to one another. For example, this is a topography of a random place. ![enter image description here][1] ##Collecting Data## Mathematica provides lots of data of various places over the world, so I take advantages of this to scrap data of on-land and underwater features for my topographies training set. The training data set includes: - 200 On-land features such as capital cities, cities, buildings, mountains. buildings = EntityList["Building"] buildings = Take[buildings, -50] mountains = MountainData[All] mountains = Take[mountains, 50] cities = EntityList["City"] // Flatten cities = Take[cities, -50] - 200 Under-water features such as trenches, basins, seamounts, etc. underseafeatures = DeleteMissing[ EntityValue[EntityClass["Ocean", "Seas"], "UnderseaFeatures"]] // Flatten underseafeatureslist = Take[underseafeatures, -200] ##Image Processing## I've done various approaches onto this Image Processing step but only one is suitable. **First Proposal** First, I was trying to calculate the slope of each topography by the following formula: ![enter image description here][2] However, it will not work effectively if there are on-land topography and underwater one having the same slope. Consequently, the machine will not be able to differentiate which is land and which is ocean. **Second Proposal** Therefore, I moved on to my second proposal from my mentor Harshal, which is using Discrete Fourier Transformation to convert an image into a matrix. As I can see, the transformedimages using DFT do not help much because I can not distinguish the differences between images although the right one is land and the left one is ocean ![enter image description here][3] As I can see, the transformed images using DFT do not help much because I can not distinguish the differences between images although the right one is land and the left one is ocean. **Third Proposal** Finally, my final solution is applying a high-frequency filter on the images. High frequency filtered output was easy to distinguish since surface above water is generally rough when compared to the surface underwater. Initially, start with 2 relief plots, one is the plot of Mount Everest and one is the plot of Mariana Trench. ![enter image description here][4] From this point, I can clearly see that the left one is Everest and the right one is Mariana Trench. The reason I can differentiate those two images because the image on the right side is rough, which means it has a high probability to be land and the image on the left side is smooth, which implies that it has a high probability to be ocean. So, let's try to find out a way to programmatically figure out these differences! capitalcitieselevationPlots = ReliefPlot[ Reverse[GeoElevationData[#, GeoRange -> Quantity[4, "Kilometers"], GeoProjection -> Automatic]], ImageSize -> Medium, ColorFunction -> GrayLevel, Frame -> False, PlotRangePadding -> None] & /@ capitalcities buildingselevationPlots = ReliefPlot[ Reverse[GeoElevationData[#, GeoRange -> Quantity[4, "Kilometers"], GeoProjection -> Automatic]], ImageSize -> Medium, ColorFunction -> GrayLevel, Frame -> False, PlotRangePadding -> None] & /@ buildings mountainselevationPlots = ReliefPlot[ Reverse[GeoElevationData[#, GeoRange -> Quantity[4, "Kilometers"], GeoProjection -> Automatic]], ImageSize -> Medium, ColorFunction -> GrayLevel, Frame -> False, PlotRangePadding -> None] & /@ mountains citieselevationPlots = ReliefPlot[ Reverse[GeoElevationData[#, GeoRange -> Quantity[4, "Kilometers"], GeoProjection -> Automatic]], ImageSize -> Medium, ColorFunction -> GrayLevel, Frame -> False, PlotRangePadding -> None] & /@ cities underseafeatureselevationPlots = ReliefPlot[ Reverse[GeoElevationData[#, GeoRange -> Quantity[4, "Kilometers"], GeoProjection -> Automatic]], ImageSize -> Medium, ColorFunction -> GrayLevel, Frame -> False, PlotRangePadding -> None] & /@ underseafeatureslist Those lines of code above transfer all the locations we got into the relief plots. In the next step, I am going to apply a high-frequency filter on the images. To illustrate, for each relief plot, I turned in into black and white and also made the black and white version blurred then found the differences between those two and thus dilate it. This is how I did it in code. finalcapitalcitieslist = Dilation[ImageDifference[Blur[#, 20], #], 10] & /@ capitalcitieselevationPlots finalbuildingslist = Dilation[ImageDifference[Blur[#, 20], #], 10] & /@ buildingselevationPlots finalmountainslist = Dilation[ImageDifference[Blur[#, 20], #], 10] & /@ mountainselevationPlots finalcitieslist = Dilation[ImageDifference[Blur[#, 20], #], 10] & /@ citieselevationPlots finalunderseafeatureslist = Dilation[ImageDifference[Blur[#, 20], #], 10] & /@ underseafeatureselevationPlots This returns: ![enter image description here][5] These are two images are the images of Mount Everest and Mariana Trench after applying the high-frequency filter. As mentioned above, the left one is Mount Everest and the right one is Mariana Trench. Henceforth, the differences are lots of "bubbles" in the left image compare to the right one where the "bubbles" represent the abrupt changes in the initial topography. ##Creating Training Set## I gathered all the separated training sets (capital cities, cities, buildings, mountains, undersea features) into a larger training set. finalonlandlist = Join[finalcapitalcitieslist, finalcitieslist, finalbuildingslist, finalmountainslist] finalunderseafeatureslist = finalunderseafeatureslist finaltraininglist = Join[finalonlandlist, finalunderseafeatureslist] ##Generating Classify Function## Creating the classify function base on the training set and also the result of each element in the set and the machine got the best fit line for my model by applying Logistic Regression method. landExamplesAndClasses = (# -> "Land" &) /@ finalonlandlist; seaExamplesAndClasses = (# -> "Sea" &) /@ finalunderseafeatureslist; predict = Classify[Union[landExamplesAndClasses, seaExamplesAndClasses]] ##Creating the Final Function to Return Probabilities## I created the final function which returns the probabilities of both land and sea as the input is a topography of an arbitrary area. predictor[img_] := predict[Dilation[ImageDifference[Blur[img, 20], img], 10], "Probabilities"] // Normal test = ReliefPlot[topography, Frame -> False, PlotRangePadding -> None] predictor[test] ##An Application: "Generating Temperature Map and Smooth Plot"## In this extra challenge, I randomly chose a place and generate the heat map of it and the smooth map as well. **Generating Temperature Map** What I have done was followed by this list: - Get the coordinates of the current location. - From current location, move to its right 15 times for 8000 meters in each step to get a list of new coordinates. - From each coordinate in the list above, move downwards 15 times for 8000 meters in each step to get a list of new coordinates. - Rearrange the list of coordinates vertical instead of horizontal. - Join the lists of coordinates above all together into a big list. - Make a list of plots for each coordinate in the list above. - For each plot, apply the Final Function the get the Probability of Land and Water. - Collect all the Land Probability of each plot and Arrange them into a 16x16-sized matrix. - From the 16x16-sized matrix, convert each number into Thermometer Colors ranging from - 0,5 to 0.5. vitri = GeoPosition[Here] vitringang = Table[GeoDestination[GeoPosition[vitri], {dist, 90}], {dist, 0, 120000, 8000}] vitridoc = Table[GeoDestination[GeoPosition[#], {dist, 180}], {dist, 8000, 120000, 8000}] & /@ vitringang vitridocdachinhsua = Table[vitridoc[[All, n]], {n, 1, 15}] tatcavitri = Join[vitridocdachinhsua, vitringang] // Flatten bando = ReliefPlot[ Reverse[GeoElevationData[{#, {(# /. GeoPosition[x_] -> x)[[1]] - 0.05, (# /. GeoPosition[x_] -> x)[[2]] + 0.05}}, GeoRange -> Quantity[4, "Kilometers"], GeoProjection -> Automatic, GeoCenter -> Automatic]], ImageSize -> Medium, ColorFunction -> GrayLevel, Frame -> False, PlotRangePadding -> None] & /@ (GeoPosition /@ tatcavitri) topo1 = predictor[#] & /@ bando // Flatten bandomoi = Partition[ Values[topo1][[#]] & /@ Flatten[Position[Keys[topo1], "Land"]], 16] MatrixPlot[bandomoi - .5, ColorFunction -> ColorData["ThermometerColors"]] And it returns: ![enter image description here][6] Let's compare it to the actual map: ![enter image description here][7] The temperature map approximately matches the actual map. However, at some points, for instance, in the sea, the color of the pixel is more red than blue. I tried to figure out the reason and found out that it might be rough because it became a water body only recently approximately couple of tens of thousands of years ago. **Generating Smooth Plot** To do this, I just applied quite same process as generating the Temperature Map above. point1 = GeoPosition[{11.111457, 107.636774}] point2 = GeoPosition[{11.111457, 109.803591}] point3 = GeoPosition[{8.991341, 107.636774}] point4 = GeoPosition[{8.991341, 109.803591}] rong = UnitConvert[GeoDistance[point1, point2], \!\(\* NamespaceBox["LinguisticAssistant", DynamicModuleBox[{Typeset`query$$ = "meters", Typeset`boxes$$ = TemplateBox[{ InterpretationBox[" ", 1], "\"m\"", "meters", "\"Meters\""}, "Quantity", SyntaxForm -> Mod], Typeset`allassumptions$$ = {{ "type" -> "Clash", "word" -> "meters", "template" -> "Assuming \"${word}\" is ${desc1}. Use as \ ${desc2} instead", "count" -> "2", "Values" -> {{ "name" -> "Unit", "desc" -> "a unit", "input" -> "*C.meters-_*Unit-"}, { "name" -> "Word", "desc" -> "a word", "input" -> "*C.meters-_*Word-"}}}}, Typeset`assumptions$$ = {}, Typeset`open$$ = {1, 2}, Typeset`querystate$$ = { "Online" -> True, "Allowed" -> True, "mparse.jsp" -> 0.3739998`7.0244163634533505, "Messages" -> {}}}, DynamicBox[ToBoxes[ AlphaIntegration`LinguisticAssistantBoxes["", 4, Automatic, Dynamic[Typeset`query$$], Dynamic[Typeset`boxes$$], Dynamic[Typeset`allassumptions$$], Dynamic[Typeset`assumptions$$], Dynamic[Typeset`open$$], Dynamic[Typeset`querystate$$]], StandardForm], ImageSizeCache->{80., {8., 18.}}, TrackedSymbols:>{ Typeset`query$$, Typeset`boxes$$, Typeset`allassumptions$$, Typeset`assumptions$$, Typeset`open$$, Typeset`querystate$$}], DynamicModuleValues:>{}, UndoTrackedVariables:>{Typeset`open$$}], BaseStyle->{"Deploy"}, DeleteWithContents->True, Editable->False, SelectWithContents->True]\)] // QuantityMagnitude dai = UnitConvert[GeoDistance[point1, point3], \!\(\* NamespaceBox["LinguisticAssistant", DynamicModuleBox[{Typeset`query$$ = "meters", Typeset`boxes$$ = TemplateBox[{ InterpretationBox[" ", 1], "\"m\"", "meters", "\"Meters\""}, "Quantity", SyntaxForm -> Mod], Typeset`allassumptions$$ = {{ "type" -> "Clash", "word" -> "meters", "template" -> "Assuming \"${word}\" is ${desc1}. Use as \ ${desc2} instead", "count" -> "2", "Values" -> {{ "name" -> "Unit", "desc" -> "a unit", "input" -> "*C.meters-_*Unit-"}, { "name" -> "Word", "desc" -> "a word", "input" -> "*C.meters-_*Word-"}}}}, Typeset`assumptions$$ = {}, Typeset`open$$ = {1, 2}, Typeset`querystate$$ = { "Online" -> True, "Allowed" -> True, "mparse.jsp" -> 0.3739998`7.0244163634533505, "Messages" -> {}}}, DynamicBox[ToBoxes[ AlphaIntegration`LinguisticAssistantBoxes["", 4, Automatic, Dynamic[Typeset`query$$], Dynamic[Typeset`boxes$$], Dynamic[Typeset`allassumptions$$], Dynamic[Typeset`assumptions$$], Dynamic[Typeset`open$$], Dynamic[Typeset`querystate$$]], StandardForm], ImageSizeCache->{80., {8., 18.}}, TrackedSymbols:>{ Typeset`query$$, Typeset`boxes$$, Typeset`allassumptions$$, Typeset`assumptions$$, Typeset`open$$, Typeset`querystate$$}], DynamicModuleValues:>{}, UndoTrackedVariables:>{Typeset`open$$}], BaseStyle->{"Deploy"}, DeleteWithContents->True, Editable->False, SelectWithContents->True]\)] // QuantityMagnitude soluongbuocnhayngang = rong/8000 + 1 // Floor soluongbuocnhaydoc = (dai - 8000)/8000 + 1 // Floor vitringang1 = Table[GeoDestination[GeoPosition[point1], {dist, 90}], {dist, 0, rong, 8000}] vitridoc1 = Table[GeoDestination[GeoPosition[#], {dist, 180}], {dist, 8000, dai, 8000}] & /@ vitringang1 vitridoc1dachinhsua = Table[vitridoc1[[All, n]], {n, 1, soluongbuocnhaydoc}] vitridoc1dachinhsua = Table[vitridoc1[[All, n]], {n, 1, soluongbuocnhaydoc}] tatcavitri1 = Join[vitridoc1dachinhsua, vitringang1] // Flatten bando1 = ReliefPlot[ Reverse[GeoElevationData[{#, {(# /. GeoPosition[x_] -> x)[[1]] - 0.05, (# /. GeoPosition[x_] -> x)[[2]] + 0.05}}, GeoRange -> Quantity[4, "Kilometers"], GeoProjection -> Automatic, GeoCenter -> Automatic]], ImageSize -> Medium, ColorFunction -> GrayLevel, Frame -> False, PlotRangePadding -> None] & /@ (GeoPosition /@ tatcavitri1) topo11 = predictor[#] & /@ bando1 // Flatten bandomoi1 = Partition[ Values[topo11][[#]] & /@ Flatten[Position[Keys[topo11], "Land"]], soluongbuocnhayngang] // Flatten kethopvitrichiso = MapThread[Rule, {tatcavitri1, bandomoi1}] GeoSmoothHistogram[kethopvitrichiso, ColorFunction -> ColorData["ThermometerColors"]] And here it is, this is the Smooth Map of a part of Vietnam which contains sea and land. ![enter image description here][8] Red regions in the heat map show land and blue show ocean and as visible ##Wrapping-up## To summarize, in the first step, I collected the topographies from both on-land and underwater. Then in the second one, the most complicated step, I had tried to use Discrete Fourier Transform (DFT) for a topography image into the matrix, but the problem was that all Fourier images were very similar. Then I tried applying a high-frequency filter on the images. High frequency filtered output was easy to distinguish since surface above water is generally rough when compared to the surface underwater. After the Image Processing Step, I created the two set of training sets, one is on-land training set and another one is underwater features training set. Hence, I went straight to build the classify function and the Final Function to Return Probabilities of "Land" and "Sea" as well. Finally, for an extra challenge also a nice application in other words for my project, I generated a Temperature Map of a part of Boston and tried to compare it to the actual map and the generated heat map is similar to the real map. ##Future Works## As we can see, from an arbitrary relief plot of a location, it is possible to turn the relief one into the thermometer surface where blue represents "Sea" and red represents "Land" by using the probabilities that the classifier returned. The first thing that needs to be done is to think of other crucial parameters that can be used, like water bodies around buildings, etc. to increase the accuracy. After increasing the accuracy and interesting thing to do would be to analyze the topography of other celestial bodies (like Mars) and then predict regions where liquids flowed on the surface. **Are these the images of wet Mars in the past and current Mars? Who knows.** ![enter image description here][9] ##Special Thanks## I would like to give my special thanks to my mentor Mr. Harshal Gajjar for guiding me and also Mr. Mads Bahrami for giving me more challenges! [Final Project GitHub link][10] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img6.jpg&userId=1725013 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img1.png&userId=1725013 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img12.png&userId=1725013 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img4.png&userId=1725013 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img11.png&userId=1725013 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img8.png&userId=1725013 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img9.png&userId=1725013 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4910img10.png&userId=1725013 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img7.jpg&userId=1725013 [10]: https://github.com/mkhangg/WSS-Final-Project Khang Minh Nguyen 2019-07-11T20:52:51Z https://community.wolfram.com/groups/-/m/t/2828058 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=PaleogeographicMaps.gif&userId=20103 [2]: https://www.wolframcloud.com/obj/5cd24f17-1b01-4dec-a917-b3d4ac97617b Jeffrey Bryant 2023-02-10T19:29:55Z https://community.wolfram.com/groups/-/m/t/840910 *CLICK to ZOOM: click on the top image to zoom and see the details.* ---------- [![enter image description here][4]][4] Vitaliy pointed out this interesting question: if you started navigating the sea perpendicularly to your favorite seashore and kept moving straight, which other place would you reach? One cannot answer this question just by tracing a straight line on a map, because that does not take into account the curvature of the Earth's surface. We must trace geodesics and see where they lead us. Let us do that with the Wolfram Language. We basically need two ingredients: a way to construct geodesics and a way to detect whether we already reached land again. To construct geodesics, we shall use GeoPath. To check whether we reached land we shall simply check if our boat has crashed, that is, whether GeoElevationData reports a positive elevation for our current position. Let us start with the latter: Take an array of elevations covering the whole world. We choose zoom 3 to have good resolution: In[1]:= Dimensions[ elevation = Reverse@ QuantityMagnitude[GeoElevationData["World", GeoZoomLevel -> 3]] ] Out[1]= {1024, 2048} Now construct an interpolating function from that data: In[2]:= elevationF = ListInterpolation[elevation, {{-90, 90}, {-180, 180}}]; The function that will tell us whether we are still at sea when our coordinates are {lat, lon} is the following. We use Mod to handle any longitude angle determination: In[3]:= seaQ[{lat_, lon_}] := Less[elevationF[lat, Mod[lon, 360, -180]], 0]; For example, the coordinate origin is at sea: In[4]:= seaQ[{0, 0}] Out[4]= True Now let us construct the geodesic that moves perpendicularly from a given segment of seashore, say the segment from the point p to the point q, starting from the midpoint of the segment. We have to tell the function whether we want to start navigating towards the right or the left. We will use a sign (+1, -1, respectively) to indicate that: In[5]:= geopath[{p_, q_}, sign_] := Module[{init, dist, dir, points}, (* Initial point of the geodesic *) init = Mean[{p, q}]; (* Maximum distance to navigate *) dist = Quantity[35000, "Kilometers"]; (* Initial direction of navigation *) dir = GeoDirection[p, q] + sign Quantity[90, "AngularDegrees"]; (* Points of the geodesic *) points = Reverse[Flatten[GeoGraphics`GeoEvaluate[GeoPath[{init, dist, dir}], Automatic, 50000] /. Line -> Identity, 1], 2]; (* Points of the geodesic at sea, until reaching the first inland point *) points = Prepend[TakeWhile[Rest[points], seaQ], init]; (* The GeoPath geo primitive to be drawn with GeoGraphics *) GeoPath[points, "TravelPath", VertexColors -> {Green, Red}] ] The use of GeoGraphics`GeoEvaluate requires explanation. This function converts a GeoPrimitive into standard Graphics primitives, and it is one of the internal steps of GeoGraphics. Its second argument specifies the geo model, that is the planet or datum (basically ellipsoidal model) of the Earth we are using; Automatic means here the default "ITRF00" datum of the Earth. Its third argument specifies the resolution in meters, so that consecutive points of the result will be separated no more than 50km. Finally, Reverse and Flatten convert back to the notation we need: a list of {lat, lon} points. We are now ready to draw the geodesics. Take the polygons of the world. We have a complete form and a simplified form: In[6]:= pol = EntityValue[Entity["GeographicRegion", "World"], "Polygon"]; In[7]:= spol = EntityValue[GeoVariant[Entity["GeographicRegion", "World"], "SimplifiedArea"], "Polygon"]; First example: draw geodesics from the segments of the simplified polygon of Australia. There are 192 points in our current version of this polygon: In[8]:= Length[ australia = EntityValue[GeoVariant[Entity["Country", "Australia"], "SimplifiedArea"], "Polygon"][[1, 1, 1]] ] Out[8]= 192 Construct the geodesics. We need to start moving towards the left, so use sign -1: In[9]:= paths = geopath[#, -1] & /@ Subsequences[australia, {2}]; Draw them with GeoGraphics, using Vitaliy's favorite black&white mapstyle. The beginnings of the geodesics are represented in green, and their ends are in red color: In[10]:= GeoGraphics[{FaceForm[White], EdgeForm[White], pol, paths}, GeoBackground -> Black, GeoCenter -> Mean[australia]] ![enter image description here][1] Let us now do the same thing, but with the complete polygon of Australia. We now have many more points: In[11]:= Length[ australia = EntityValue[Entity["Country", "Australia"], "Polygon"][[1, 1, 1]] ] Out[11]= 5140 In[12]:= GeoGraphics[{FaceForm[White], EdgeForm[White], pol, paths}, GeoBackground -> Black, GeoCenter -> Mean[australia]] ![enter image description here][2] It is quite interesting to see how many places we can reach from Australia. In particular we can reach the US East coast, after crossing the Atlantic! And finally, let us do the same thing for the polygon of the Americas. We extract it from the polygons of the world: In[13]:= Length[america = spol[[1, 2, 1, 1, 1, 1, 1]]] Out[13]= 1333 In[14]:= paths = geopath[#, -1] & /@ Subsequences[america, {2}]]; In[15]:= GeoGraphics[{FaceForm[White], EdgeForm[White], pol, paths}, GeoBackground -> Black, GeoCenter -> Mean[america]] ![enter image description here][3] This time, let us use the Mercator projection. There are many segments, so be patient... In[16]:= Length[america = pol[[1, 2, 1, 1, 1]]] Out[16]= 22751 In[17]:= paths = geopath[#, -1] & /@ Subsequences[america, {2}]]; In[18]:= GeoGraphics[{FaceForm[White], EdgeForm[White], pol, Thin, paths}, GeoBackground -> Black, GeoCenter -> Mean[america], GeoProjection -> "Mercator"] [![enter image description here][4]][4] Note that GeoElevationData is a bit imprecise in the area of the East Siberian sea, north of Russia, where the seafloor is not very deep, and the geodesics get interrupted there. There are also some discrepancies around Antarctica, due to the ice masses. Jose. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-15at23.08.09.png&userId=54190 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-15at23.10.09.png&userId=54190 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-15at23.28.00.png&userId=54190 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-04-15at23.20.41.png&userId=54190 [at0]: http://community.wolfram.com/web/vitaliyk Jose Martin-Garcia 2016-04-16T04:48:16Z https://community.wolfram.com/groups/-/m/t/784207 [Dr. P. David Polly from Indiana University][1] published a [Phylogenetics package for Mathematica][2]. A detailed [User's Guide][3] is also available. Short discription is copied below. **Keywords**: Phylogenetics; Ancestral Node Reconstruction; Newick Trees **Abstract**: This add-in package for Mathematica performs basic phylogenetic functions, including reading and drawing Newick format trees, calculating phylogenetically independent contrasts, reconstructing ancestral values for continuous traits, performing random walks, and simulating continuous traits on phylogenetic trees. The file is a ".m" file, which can be imported into Mathematica 6.0 and later (functions do not work in earlier versions of Mathematica). Install using the "Install" item on the "File" menu. Once installed, you must load the package like any other with the line `<<PollyPhylogenetics`, using either this suggested name or another. [1]: http://mypage.iu.edu/~pdpolly [2]: https://scholarworks.iu.edu/dspace/handle/2022/14614 [3]: http://mypage.iu.edu/~pdpolly/Software/Guide%20to%20PollyPhylogenetics%203.0.pdf Vitaliy Kaurov 2016-02-01T13:07:47Z https://community.wolfram.com/groups/-/m/t/1333342 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][1] 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}]}] ![enter image description here][3] 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] ![enter image description here][4] 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! [1]: http://reference.wolfram.com/language/ref/EarthquakeData.html [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=SeismicPlot.jpeg&userId=1036924 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Map.jpeg&userId=1036924 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Depth.jpeg&userId=1036924 Null Null 2018-05-06T16:39:08Z https://community.wolfram.com/groups/-/m/t/1345014 The Wolfram Language comes with lots of great functions, but one of my all-time favorites is [`GeoGraphics`][1] and all its `GeoSiblings`. Here is a simple example of how easy it is to create a map in the Wolfram Language: GeoGraphics[Interpreter["City"]["nyc"]] ![enter image description here][2] And you can use some built-in 'backgrounds' as well, for example: GeoGraphics[Interpreter["City"]["washington dc"], GeoBackground -> "ContourMap"] ![enter image description here][3] A perhaps lesser known option, but very useful one is the [`GeoServer`][4] option, which lets you point to any tilemap server: GeoGraphics[Interpreter["City"]["rome, italy"], GeoServer -> "http://b.tile.openstreetmap.org/`1`/`2`/`3`.png"] ![enter image description here][5] This is a very powerful feature, because there are many many tilemap servers in existence. Many are free for personal use and others require some sort of subscription with a key to unlock the tilemap server. Finding all of them is a hassle, so I am making a `GeoService` function available in [my `Prototype` paclet on GitHub][6]. This is a paclet which provides a number of half-baked (and sometimes fully baked!) functions that are not (or not yet) in the core Wolfram Language. Here is how you get this paclet (and the functions described in this post): PacletInstall[ "https://github.com/arnoudbuzing/prototypes/releases/download/v0.2.7/Prototypes-0.2.7.paclet"] (You may need to `Quit` and restart the Wolfram Language after this) The `GeoService` function is a collection of a number of publicly documented tilemap servers: GeoService["Properties"] Here is the output: {"OpenStreetMap", {"OpenStreetMap", "France"}, {"OpenStreetMap", "France", "Humanitarian"}, "WikiMedia", "HikeAndBike", {"WaymarkedTrails", "Hiking"}, {"WaymarkedTrails", "Cycling"}, "SkiMap", "HillShading", {"OpenCycleMap", "Cycle"}, {"OpenCycleMap", "Transport"}, {"Mapnik", "Grayscale"}, {"Mapnik", "LabelFree"}, {"Stamen", "Toner"}, {"Stamen", "Watercolor"}, {"ThunderForest", "Landscape"}, {"ThunderForest", "Outdoors"}, "Opnvkarte", "OpenPtMap", {"Carto", "Dark"}, {"Carto", "Light"}, "OpenSeaMap", {"OpenRailwayMap", "Standard"}, {"OpenRailwayMap", "MaxSpeed"}, {"OpenRailwayMap", "Signals"}, {"ArcGIS", "UnitedStatesTopographical"}} Already immediately this gives you a whole new set of maps you can make. Here are some examples: GeoGraphics[Interpreter["City"]["athens, greece"], GeoServer -> GeoService[{"Mapnik", "LabelFree"}]] ![enter image description here][7] GeoGraphics[Interpreter["City"]["cairo, egypt"], GeoServer -> GeoService["WikiMedia"]] ![enter image description here][8] But all these maps are single layered, whereas several tilemap servers provide transparent layers for some "theme". For example here is a layer which contains only hiking trails in a part of the [Yorkshire Dales][9]: GeoGraphics[Interpreter["City"]["malham, united kingdom"], GeoServer -> GeoService[{"WaymarkedTrails", "Hiking"}]] ![enter image description here][10] This sort of layer is most useful when it is combined with another (non-transparent background) layer. One way to achieve this is to use the `Overlay` functions which can display one Wolfram Language expression on top of another: Overlay[{"XXXX ", " OOOO"}] ![enter image description here][11] In the ["Prototype" paclet][12] (described above) I defined a `LayeredGeoGraphics` function which uses [`Overlay`][13] to stack multiple layers. Here is an example which shows hiking trails against a grayscale [Mapnik][14] layer: LayeredGeoGraphics[ Interpreter["City"]["malham, united kingdom"], {{"Mapnik", "Grayscale"}, {"WaymarkedTrails", "Hiking"}}, GeoRange -> Quantity[1, "Miles"]] ![enter image description here][15] And of course you can stack more than two layers. Here is an example of a label-free background layer from [Mapnik][16], with a hill-shading layer and a hiking trail layer on top of it (The hill-shading provides the "depth" look and feel): LayeredGeoGraphics[ Interpreter["City"]["malham, united kingdom"], {{"Mapnik", "LabelFree"}, "HillShading", {"WaymarkedTrails", "Hiking"}}, GeoRange -> Quantity[1, "Miles"]] ![enter image description here][17] The possibilities are endless! If you find additional tilemap servers please feel free to add them here as a comment, or make a pull request in my [Prototypes github repo][19]. More layers = more possibilities! [1]: http://reference.wolfram.com/language/ref/GeoGraphics.html [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=gg-01.png&userId=22112 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=gg-02.png&userId=22112 [4]: http://reference.wolfram.com/language/ref/GeoServer.html [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=gg-03.png&userId=22112 [6]: https://github.com/arnoudbuzing/prototypes [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=gg-04.png&userId=22112 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=gg-05.png&userId=22112 [9]: https://en.wikipedia.org/wiki/Yorkshire_Dales [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=gg-06.png&userId=22112 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=gg-07.png&userId=22112 [12]: https://github.com/arnoudbuzing/prototypes [13]: http://reference.wolfram.com/language/ref/Overlay.html [14]: http://mapnik.org/ [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=gg-08.png&userId=22112 [16]: http://mapnik.org/ [17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=gg-10.png&userId=22112 [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=gg-09.png&userId=22112 [19]: https://github.com/arnoudbuzing/prototypes Arnoud Buzing 2018-05-24T19:58:32Z https://community.wolfram.com/groups/-/m/t/984239 I'm in Chicago and this past week has been brutally cold. I decided it would be fun to see just how bad it is by visualizing this year's temperatures against previous years. The results were good and I thought I'd share. ![enter image description here][1] First, we get about 60 years of temperature data. This data has some Missing values in it, but our code will handle this problem automagically: temps = WeatherData["Chicago" , "MeanTemperature", {{1950, 1, 1}, Today, "Day"}, "DateNonMetricValue"] I've also asked for the values in Fahrenheit instead of the the default Celsius. You can just remove "DateNonMetricValue" if you don't like that. Making this data into a DataSet will help us efficiently manipulate it. We want to group all the temperatures by Month and Day so we can calculate things like the Mean and Max temperatures for any given day of the year. tempDataset = Dataset@Normal@temps; groupedByMonthDay = tempDataset[GroupBy[First /* (DateValue[#, { "Month", "Day"}] &)]] ![enter image description here][2] Let's select just the list of temperatures for each Day: groupedByMonthDayTemps = groupedByMonthDay[All, All, 2] Now we can look at the Mean temperature for each day by evaluating: groupedByMonthDayTemps[All, Mean] We are going to reduce the list temperatures for each day with several different ways, so let's make a function out this. It will take a reducing function like Mean and apply it to each day's list of temperatures. tempsReducedBy[transform_] := groupedByMonthDayTemps[All, transform]; I want to look at the median temperatures as well as the minimum, maximum, and upper and lower quartiles. The functions that do this are: reductionFunctions = {Min, Max, Median, Quantile[#, 3/4] &, Quantile[#, 1/4] &}; We can get the daily minimum temperatures and other values using them: {minTemps, maxTemps, medianTemps, upperQTemps, lowerQTemps} = tempsReducedBy /@ reductionFunctions Unfortunately, when we plot these, we see they are kinda bumpy: ListPlot@minTemps[Values] ![enter image description here][3] I just just want a general curve showing what the minimum temperatures are like. We need to smooth these out. There's a lot of ways to do this. I at first chose to use the Fourier Transform myself, but realized there's a function for LowPass Filtering: filterTemps[temps_] := LowpassFilter[Normal@temps[[Values]], 1/20, 80, HammingWindow, Padding -> "Periodic"] The values here are admittedly just magic numbers I've picked for aesthetic reasons. Let's add this to our code: {minTemps, maxTemps, medianTemps, upperQTemps, lowerQTemps} = Map[filterTemps@*tempsReducedBy, reductionFunctions]; If we plot these together, we get a good a good background for how much the temperature varies throughout the year. The code is a bit long because I got picky about how I wanted it to look: background = DateListPlot[{ Callout[minTemps, "Likely Record Low"], Callout[maxTemps, "Likely Record High"], Callout[medianTemps, "Median"], Callout[upperQTemps, "Upper Quartile"], Callout[lowerQTemps, "Lower Quartile"]}, {{2016, 1, 1}, Automatic, "Day"}, Joined -> True, PlotStyle -> Gray, FrameLabel -> Automatic, FrameTicks -> {Table[{2016, i, 1}, {i, 12}], Automatic}, Axes -> False] ![enter image description here][4] Let's get this years temperatures and lay it over our background: currentTemps = WeatherData[city, "MeanTemperature", {{2016, 1, 1}, Today, "Day"}, "DateNonMetricValue"]; thisYear = DateListPlot[currentTemps, Joined -> True, PlotStyle -> Darker@Red] ![enter image description here][5] And let's lay it on top of our background: Show[background, thisYear, PlotLabel -> Style["Daily Mean Temperature - Chicago - 2016", Large, FontFamily -> "Times"]] ![enter image description here][6] So, it's certifiably ridiculously cold in Chicago. And yesterday was almost record breaking. Here are some graphs for other cities that like to complain about the cold. As we can conclusively see, my friends from other cities should stop complaining about how cold it is outside. Chicago has it far worse right now: ![enter image description here][7] ![enter image description here][8] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Chicago_during_early_2014_North_American_Cold_Wave.jpg&userId=20642 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-12-20at10.29.52PM.png&userId=20642 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=mintemps.png&userId=20642 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=8458Background.png&userId=20642 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=posterworkingcopy.png&userId=20642 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Chicago.png&userId=20642 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=newyork.png&userId=20642 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=seattle.png&userId=20642 Sean Clarke 2016-12-21T04:25:57Z https://community.wolfram.com/groups/-/m/t/834097 **What is distribution of wind speed magnitudes at a given geographic location?** You could approach this manually like the authors of this paper: [Mixture probability distribution functions to model wind speed distributions][1] where main conclusion was: > Results show that mixture probability functions are better alternatives to conventional Weibull, two-component mixture Weibull, gamma, and lognormal PDFs to describe wind speed characteristics. Or you can use Machine Learning and new function FindDistribution. Let's first get a sample of data, say for Boston for recent 5 years: windBOSTON = WeatherData["Boston", "WindSpeed", {{2010}, {2015}, "Day"}]; DateListPlot[windBOSTON] ![enter image description here][2] Now get the magnitudes and apply FindDistribution mags = QuantityMagnitude[windBOSTON["Values"]]; dis = FindDistribution[mags] which gives, guess what, a MixtureDistribution : MixtureDistribution[{0.711353, 0.288647}, {NormalDistribution[12.8117, 4.74919], LogNormalDistribution[3.06178, 0.308954]}] Visualizing model versus experimental data looks neat! Show[ Histogram[mags, Automatic, "ProbabilityDensity", PlotTheme -> "Detailed"], Plot[PDF[dis, x], {x, 0, 50}, PlotRange -> All]] ![enter image description here][3] Try playing with other locations and see what distributions you get. Not always we will get a MixtureDistribution, wind data at different locations can be quite different. [1]: http://link.springer.com/article/10.1186/2251-6832-3-27 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sdfasq54yhtgfd.png&userId=11733 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sdfasfq3ergfadv.png&userId=11733 Vitaliy Kaurov 2016-04-04T20:48:16Z https://community.wolfram.com/groups/-/m/t/293403 TL;DR --- I have three issues with getting sun positions in Mathematica V10: - It is extremely slow compared to V9 - It doesn't *seem* to yield correct results - a) It needs an Internet connection, which b) is not assured to always return results and c) if not used optimally can easily consume your monthly allowance of W|A calls Long story === With the advent of V10 `AstronomicalData` has been deprecated, as shown on its documentation page: ![enter image description here][1]. I'm not an astronomer, so my main use of this function has been restricted to its capability to get the sun position using functions calls like this: { AstronomicalData["Sun", {"Azimuth", {2013, 3, 1, #, 0, 0}, {52.37`, 4.89`}}, TimeZone -> 1], AstronomicalData["Sun", {"Altitude", {2013, 3, 1, #, 0, 0}, {52.37`, 4.89`}}, TimeZone -> 1] } & /@ Range[0, 23] > {{341.47732, -43.93930}, {2.33417, -45.21747}, {22.94232, -43.19133}, > {41.52167, -38.28400}, {57.55208, -31.30276}, {71.47253, -23.03159}, > {84.02194, -14.08294}, {95.91940, -4.92723}, {107.80166, 4.03418}, {120.23770, 12.40167}, {133.72303, 19.72563}, {148.59433, > 25.48377}, {164.84179, 29.12209}, {181.93103, 30.19428}, {198.91284, > 28.55117}, {214.89602, 24.41962}, {229.46400, > 18.28613}, {242.70064, 10.70703}, {254.98998, > 2.19073}, {266.84760, -6.82566}, {278.85594, -15.94505}, {291.66723, -24.75464}, {306.00911, -32.75641}, {322.57956, > -39.29877}} So, this gets me the sun positions in steps of an hour during a particular day in Amsterdam (TZ 1). The same call still works in V10, though it now returns numbers with units; degrees in this case. On its first call, it reads some paclet information from a Wolfram server, but on any successive call no Internet connection is needed. I will be going into detail about timing further on, but I'll say here that the V10 function takes about three times longer than its V9 namesake. I blame the addition of units for that. With `AstronomicalData` apparently deprecated we are supposed to use its successors. In this case I need `SunPosition`. A direct translation of the above would be: SunPosition[GeoPosition[{52.37`, 4.89`}], DateObject[{2013, 3, 1, #, 0, 0}, TimeZone -> 1]] & /@ Range[0, 23] > {{95.7, -5.1}, {107.6, 3.9}, {120.0, 12.3}, {133.5, 19.6}, {148.3, 25.4}, {164.5, 29.1}, {181.6, 30.2}, {198.6, 28.6}, {214.6, 24.5}, {229.2, 18.4}, {242.5, 10.9}, {254.8, 2.4}, {266.6, -6.7}, {278.6, -15.8}, {291.4, -24.6}, {305.7, -32.6}, {322.2, -39.2}, {341.3, -43.5}, {2.0, -44.8}, {22.5, -42.9}, {41.1, -38.0}, {57.1, -31.1}, {71.0, -22.9}, {83.6, -13.9}} As with the new `AstronomicalData` the output is actually in degrees which I have removed in the above output for the sake of clarity. There are a few things to note: - `SunPosition` uses position and date objects, the latter being new in V10 - `SunPosition` does not have a `TimeZone` option, but you can set it in `DateObject` - `SunPosition` can use the old lat/long list position indication. It also can use a date list to enter the date instead of a `DateObject`. In the latter case you are out of options with respect to time zones and you have to add the appropriate amount of time offset - It is extremely slow, and it may even time-out: ![enter image description here][2] - Last but not least: the results seem to be plain wrong. It suggests that sunrise is somewhat before 1 am, which is -of course- incorrect. I assume that this has something to do with a `$GeoLocation` setting for the observer of the sun positions, but I haven't managed to sort out what I am supposed to enter to get the correct sun positions for the location provided in the same call. As to timing: I noticed very inconsistent timings for `SunPosition` compared to `AstronomicalData`, so I used the following code to collect a somewhat more statistical sound sample: SetAttributes[timingTest, HoldFirst]; timingTest[code_, repeats_Integer] := Table[ ClearSystemCache[]; code // AbsoluteTiming // First, {repeats} ] Using this, I collected timing of 20 calls to the following code snippets: - `AstronomicalData` V9 and V10: As above - `SunPosition`: As above - `SunPosition` without `GeoPosition`, just the lat/long list. - `SunPosition` without `GeoPosition`, and also without the `DateObject` date, just a classical date list (with the hour set to +1 to accommodate TZ 1) - `SunPosition` V10 without `GeoPosition` and with the `Map` (`/@`) gone and replaced by a `DateRange` inside the call. In the last case, the returned value is a `TimeSeries` object from which I extract the positions using the `"Paths"` method: SunPosition[{52.37`, 4.89`}, DateRange[{2013, 3, 1, 1, 0, 0}, {2013, 3, 1, 24, 0, 0}, "Hour"]]["Paths"][[1, All, 2]] The results were as follows: ![enter image description here][3] Clearly, the `SunPosition` results are very disappointing. Getting the sun positions with `SunPosition` is almost 40 times slower than using the old V9 method (which, I should add, wasn't particularly quick either. I have an implementation in Mathematica code which is faster). The V10 implementation of `AstronomicalData` is also more than three times slower than the V9 version. The `DateRange` version of the call saves a lot of communication overhead. Still, it is almost *five times slower* than in V9. The cause of all this slowness is that `SunPosition` simply does a call to Wolfram|Alpha. Sniffing the communication one sees the following string passed to the server: "1:eJxTTMoPSuNgYGAoZgESPpnFJcHcQEZwaV5AfnFmSWZ+XhoTsmxR/6GvGjH9wg4Qhr6XQxobsnzmXXYGhkxmIC+TEUSIgwggZihigIJgoAIGj/yizKr8PJigA5yBZtubwB1yrdxeDkXVIuvcH1aJOBRzAqUcS0vycxNLMpMBSAArww==" which can be turned into readable form using `Uncompress`: {"SunPosition", {4.89, 52.37}, {2013, 3, 1, 23, 0, 0.}, "Horizon", 2., 2., {52.09, 5.12}, Automatic} Here, we can recognize the lat/long of the position I used (but with lat/long reversed - Is this somehow significant?). At the end is my own `$GeoLocation`, but I don't believe it is used at all (and it shouldn't: I'm asking for the sun position over Amsterdam, not where I live). Changing it with `Block` I get the same results: Block[{$GeoLocation = GeoPosition[{52.37`, 40.89`}]}, SunPosition[{52.37`, 4.89`}, {2013, 3, 1, 1, 0, 0}]] Apart from the slowness, there's the issue of the necessary Internet connectivity (Want to give a demonstration and you don't have Internet? Sorry, you're out of luck). And what of the use of W|A calls? Each of the `SunPosition` tests (except the last one) took me 20 * 24 = 480 calls. So this part of my testing only already took 1440 calls, and one should be reminded that a typical Home Use license allows for only 3,000 calls per month. Things like this can go pretty fast. In fact, I once wrote an application that calculates the impact of building changes on shadows around your house throughout the year. It does in the order of 17,000 `AstronomicalData` calls. I couldn't implement that naively using `SunPosition` and have it actually work. Clearly, one should now use the `DateRange` version of the call as much as possible. ---------- To wrap up: I have one real question, i.e., how to get `SunPosition` to return the same values as `AstronomicalData`, and a request to the WRI team: please put `SunPosition` in the kernel and don't use W|A calls, because the situation as it is now is rather annoying and IMHO a real step backwards. [1]: /c/portal/getImageAttachment?filename=AstronomicalData.png&userId=43903 [2]: /c/portal/getImageAttachment?filename=timeout.png&userId=43903 [3]: /c/portal/getImageAttachment?filename=results.png&userId=43903 Sjoerd de Vries 2014-07-13T16:39:48Z https://community.wolfram.com/groups/-/m/t/2740397 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/2d627ca1-036a-4d6e-afaa-bd73bd641674 Jose Martin-Garcia 2022-12-21T15:37:36Z https://community.wolfram.com/groups/-/m/t/325930 Data credit: [Icelandic Met Office][1] [Animated results][2] (using techniques shown below) and [how to generate them][3]. In 2010 the volcano [Eyjafjallajökull][4] erupted and shut down (among other things) transatlantic air travel for about six days. This time it is the volcano [Bárðarbunga][5] which appears to be ready to erupt. The Icelandic API web site [http://apis.is][6] is providing a useful service, by tracking all measured earthquakes and formatting them as JSON output, which is easily imported into the Wolfram Language. In this post I will make use of this data to visualize these earthquakes. The first step is to import the dataset and to transform it into a Wolfram Language data structure aptly named [Dataset][7]. dataset = Dataset[Map[Association, "results" /. Import["http://apis.is/earthquake/is", "JSON"]]]; We can inspect the content of this earthquake data by simply evaluating the *dataset* symbol: dataset ![dataset][8] And we can also sort the data on any column, by using the SortBy function on the *depth* column. In this case I use *-depth* to sort from deepest earthquake to shallowest: dataset[SortBy[-#depth &]] ![dataset sorted][9] Now, let's make a geographical map of the area around Bárðarbunga. Here, we can use the natural language input which can be accessed by pressing the Ctrl key and the = key simultaneously. This brings up the natural language input field: ![natural language input][10] Now type in that field and hit the Enter key (followed by Shift-Enter to evaluate the input cell): ![natural language result][11] We can do this anywhere in the input, so now we can create a map of the area near Bárðarbunga. We use the GeoGraphics function and place a GeoMarker at the center of the volcano, using a iconic image for a volcano. We set the GeoRange to 100km to see the surrounding area including a piece of Iceland's coastline. For the map background we use the contour map styling: ![background map][12] To get all the earthquake positions as little round disks, we extract the latitude and longitude from the dataset as values and then wrap them in GeoDisk with a radius of 1km: earthquakes = Normal[ dataset[ All, {"latitude", "longitude"} /* Values /* (GeoDisk[#, Quantity[1, "Kilometers"]] &)]]; And then plot them as red disks on the previous map: ![map][13] To make a slightly more refined image we can composite a relief map with a contour map and overlay the earthquake data (here *volcanoimage* is the image used above to indicate the volcano location): reliefmap = GeoGraphics[ Entity["Volcano", "Bardarbunga"], GeoRange -> Quantity[100, "Kilometers"], GeoBackground -> GeoStyling["ReliefMap"], ImageSize -> Large]; contourmap = GeoGraphics[Entity["Volcano", "Bardarbunga"], GeoRange -> Quantity[100, "Kilometers"], GeoBackground -> GeoStyling["ContourMap"], ImageSize -> Large]; overlay = GeoGraphics[{{Red, earthquakes}, GeoMarker[Entity["Volcano", "Bardarbunga"], volcanoimage]}, GeoRange -> (GeoRange /. Options[contourmap, GeoRange]), GeoBackground -> None, ImageSize -> Large]; Overlay[{ImageCompose[reliefmap, {contourmap, .5}], overlay}] ![final map][14] [1]: http://en.vedur.is/ [2]: https://vimeo.com/104637028 [3]: http://community.wolfram.com/groups/-/m/t/330289 [4]: http://en.wikipedia.org/wiki/Eyjafjallaj%C3%B6kull [5]: http://en.wikipedia.org/wiki/B%C3%A1r%C3%B0arbunga [6]: http://apis.is [7]: http://reference.wolfram.com/language/ref/Dataset.html [8]: /c/portal/getImageAttachment?filename=one.PNG&userId=22112 [9]: /c/portal/getImageAttachment?filename=two.PNG&userId=22112 [10]: /c/portal/getImageAttachment?filename=bbd3.PNG&userId=22112 [11]: /c/portal/getImageAttachment?filename=bbd4.PNG&userId=22112 [12]: /c/portal/getImageAttachment?filename=bbd8.PNG&userId=22112 [13]: /c/portal/getImageAttachment?filename=bbd7.PNG&userId=22112 [14]: /c/portal/getImageAttachment?filename=bbd9.PNG&userId=22112 Arnoud Buzing 2014-08-22T13:25:02Z https://community.wolfram.com/groups/-/m/t/471232 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/dd8fb9a3-d593-4377-863e-8f4b75252b0c Jeffrey Bryant 2015-04-01T00:53:17Z https://community.wolfram.com/groups/-/m/t/2489121 ![enter image description here][2] &[Wolfram Notebook][3] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3071Untitled.png&userId=73716 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3071Untitled.png&userId=73716 [3]: https://www.wolframcloud.com/obj/026709ec-37ec-4e2f-93f7-ec74bc6cc84d Sander Huisman 2022-03-12T19:29:52Z https://community.wolfram.com/groups/-/m/t/1732295 ![Cover image][1] ## What are we trying to do? The goal of this project is to produce an algorithm which can find the physical scale of any satellite image: the relationship between the content of the image, and the area it covers in kilometers. ![Examples of training data][2] This is a very challenging problem because of the characteristics of the world's terrain. At different zoom levels, it's highly self-similar, like a fractal. We need to find a method to extract useful information from these images, while also ignoring the parts which are repeated across zoom levels. There are several ways to approach the problem. Some of the more manual methods involve trying to label image parts which only show up at certain scales. For instance, you could rely on the fact that all rooftops are generally roughly the same size, all roads have similar widths, and so on. ![Examples of man-made structure][3] Those approaches all need lots of manual work, though. We attempted to solve the problem automatically, exploring ideas that might let us predict map zoom without relying on hard-coded rules. Although we explored several approaches to this problem, the most successful solution used feature extraction to convert each image to a relatively small vector, then trained a small feed-forward neural network to predict zoom from each set of features. Although the self-similarity of each image makes more traditional CV approaches very difficult, a neural network can learn the right features to approximate the zoom very well. ## Methodology We wound up gathering several datasets of satellite images over the course of the project. The most useful one was a dataset of three thousand images of random locations in the continental United States, all taken at different zoom levels: ``` (* define a function to download images of a specific location and zoom *) satelliteImage[location_, size_?NumericQ] := GeoImage[ GeoDisk[location, Quantity[size/2, "km"]], GeoServer -> "DigitalGlobe", RasterSize -> 400 ] sampleCount = 3000; (* Get a list of 3000 random locations in the continental US *) randomLocations = RandomGeoPosition[Entity["Country", "UnitedStates"], sampleCount] /. GeoPosition[locs_List] :> GeoPosition /@ locs; (* Get a list of 1000 random zoom levels, from 1 to 200 km *) randomZooms = Table[RandomReal[{1, 200}], sampleCount]; (* create a dataset of image specifications *) samples = MapThread[ <|"Location" -> #1, "Zoom" -> #2|> &, {randomLocations, randomZooms} ] // Dataset; (* to see the precise scripts used to download each image, download the attached notebook--they have dynamic progress indicators and checkpoint the data to disk, so they're a little complicated *) ``` Working on this project, the majority of the time was spent trying several different methods to extract information from images. One attempt was visual pre-processing: running segmentation or binarization on each image before training a model or extracting some metric. Every time we did this, although the images looked really neat, the accuracy of our predictions were far worse. ![Examples of image preprocessing][4] All of those preprocessing methods reduce the dimensionality of the images, but it turns out that they focus on the wrong features in the process. Our network was supposed to pick up on the large patterns: rivers, landmasses, and so on. When we segmented images, the network was forced to focus on the small details we highlighted. All in all, preprocessing using traditional CV was a failure. We also tried training a convolutional neural network from scratch on the images, which also failed. The network would, at first, immediately overfit the training set. When we reduced its size, it would fail to converge at all. Despite hours of tweaking, this method did not work either. The next idea we had was just to throw the entire dataset into `Predict[]` and see what would happen. This worked shockingly well, considering how easy it was: ![Predict results][5] So the next question we had was: how? What was `Predict[]` doing behind the scenes? Doing some research, we discovered a couple starting points for our own neural network model: - `Predict[]` preprocesses images using WL's feature extraction functionality. This is based on the first few layers of the trained `ImageIdentify` convnet, combined with an autoencoder. - `Predict[]` generally trains small feed-forward networks, without convolutional layers. Our general approach was to replicate this setup, with several tweaks and optimizations for better performance. Our first large improvement was a pre-processing step: image augmentation. We applied several different constant crops, translations, rotations, and reflections to each image, in order to increase the number of examples we had by a factor of 10. We then performed feature extraciton on the augmented data. ``` (* use the built-in augmentation functionality *) (* note: this can't go in the network itself because we need to extract features with FeatureExtraction[] after this step *) augmentor = ImageAugmentationLayer[ (* Final image dimensions--from cropping *) {200, 200}, (* 50% change of either reflection *) "ReflectionProbabilities" -> {0.5, 0.5}, "Input" -> NetEncoder[{"Image", {400, 400}}], (* 400x400 input images *) "Output" -> NetDecoder["Image"] (* output an image for the feature extractor *) ] (* each original image gets 10 augmented images generated from it *) augmentationMultiplier = 10; (* actually augment the image set *) augmentedImages = Join@@Table[ imageSet[ All, <| #, "Image" -> augmentor[#Image, NetEvaluationMode -> "Train"] |> &], augmentationMultiplier ] // RandomSample; ``` Our next approach was to replicate this--use `FeatureExtraction[]` to reduce the dimensionality of the images, and train a small, mostly-linear neural network on the result. ``` (* create a feature extractor trained with the first 5000 images*) fExtractor = FeatureExtraction[augmentedImages[;; 5000, "Image"]]; (* extract features from the images *) features = imageSet[All, <|#, "Features" -> fExtractor[#Image]|> &] ``` When you plot the feature vectors of a few images, you can see the variance between them is clear: ![Feature--image matrix][6] Although the network structure was fairly simple, we automated the generation of good hyperparameters. We trained hundreds of slightly-different networks, and evaluated their statistical performance. Out of many different permutations of layer count, layer size, activation function choice, training speed, and so on, we picked the ones which work best. The final network design we settled on was this: ``` geoNet = NetChain[ { 200, Ramp, DropoutLayer[0.3], 100, Ramp, 20, 1 }, "Input" -> {324}, (* our feature vectors are 335-dimensional *) "Output" -> NetDecoder["Scalar"] (* decode into a single number: zoom in km *) ]; geoNet = NetTrain[ geoNet, (* feature(Train|Test) all have the shape { {feature, ...} -> zoom, ...} *) featureTrain, ValidationSet -> featureTest, TargetDevice -> "GPU", MaxTrainingRounds -> 600, (* bail if loss stops decreasing *) TrainingStoppingCriterion -> <|"Criterion" -> "Loss", "Patience" -> 50|> ] ``` In the end, the general architecture of the most successful model looked like this: +--------------------+ | | | Original dataset | Generated from GeoImage[] | | +--------------------+ | | | | | | | | V V V V +---------------------------+ | +---------------------------+ | | +---------------------------+ | | | | | | Generated with | | | Augmented dataset | | | ImageAugmentationLayer[] | | | | | | +-|-|-----------------------+ | | +-|-------------------------+ | +---------------------------+ | | | | | | | | V V V V ---------------------------------------------- ---------------------------------------------- ------- Extracted feature vectors ------------ using FeatureExtraction[] ---------------------------------------------- ---------------------------------------------- | | | | | | | | V V V V # # # # # # # # # # # # # # # Small-ish neural network |\/|\/|\/|\/|\/|\/|\/| / / / / / / / |/\|/\|/\|/\|/\|/\|/\|-/--/--/--/--/--/--/ # # # # # # # # |\/|\/|\/| / / / / |/\|/\|/\|-/--/--/--/ # # # # |-/--/--/ | # <-- our final prediction! ( https://textik.com/#e650301054ce435f ) ## Results When we evaluated each image in our test set with this network, we got the following results: ![Plot of prediction results][7] This plot shows actual zoom levels on the $x$-axis, and estimated zoom on the $y$. A reference line shows what a perfect prediction would look like. Analyzed statistically, the network had a standard deviation of 30.37 km, and an $r^2$ value of 0.732. This network clearly "gets the gist" of the data it's presented. However, these results were not portable to different satellite image datasets. When we evaluated a separate test set, gathered from Wolfram satellite imagery, we got this result: ![Plot of prediction results on Wolfram satellite data][8] It is clear that the network is learning something specific to the DigitalGlobe dataset we used to train it. We would hesitate to call that overfitting, because it can extrapolate to locations it has never seen before, but it relies on the specific look and tone of the DigitalGlobe data. After all, the two image sets look very different: ![Satellite image comparison][9] It is possible that the network is just confused by the new colors, rather than confused by the structure of the terrain in the Wolfram dataset. Either way, though, the scope of this result is limited to images similar to the satellite dataset on which it was trained. We used another dataset of 20,000 mostly-overlapping images of Massachusetts and exploited overfitting to achieve a much more accurate (yet fragile) prediction. By managing to overfit the terrain, the model could achieve up to an $r^2$ of 0.99, but completely fell apart on any other dataset. Theoretically, you could take this brute-force approach with the entire planet, overfitting deliberately to learn the terrain. However, in our scope, we could not attempt this. ## Future work One of the larger problems with this research was gathering data. In future attempts, it would be better to gather a much larger dataset (somewhere around 50,000 images) from several different satellite providers. To stop the network from overfitting on the fine-grained style of the images, we would need to find satellite providers whose data are significantly different. One other option is to improve the model's feature extraction layer. Right now, the FeatureExtraction function uses the first few convolutional layers of the Wolfram ImageIdentify classifier as a starting point. By training our own convolution step specific to satellite images on a much larger dataset, we might be able to get more accurate results. # Final thoughts This research was successful in very limited scope. Future attempts at cracking this problem will have to successfully generalize to the entire globe, across several satellite image providers---a problem requiring a lot of time, and access to large computational resources, to solve. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=cover-image.png&userId=1619260 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=fig_examples.png&userId=1619260 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2123fig_structure.png&userId=1619260 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=fig_processing.png&userId=1619260 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2381fig_predict.png&userId=1619260 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=fig_featurematrix.png&userId=1619260 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=fig_resultplot.png&userId=1619260 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=fig_resultplotwolfram.png&userId=1619260 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=fig_satcomparison.png&userId=1619260 William Goodall 2019-07-11T23:29:28Z