Community RSS Feed
https://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Recreation sorted by activeWhich countries did @therealdonaldtrump tweet about?
https://community.wolfram.com/groups/-/m/t/1727272
Introduction
----------
A couple of days ago on 1 July [The Economist][1] tweeted [this][2]:
> Since he was elected in 2016 Donald Trump has made 1,384 mentions of foreign countries on Twitter. Can you guess which one he named most often?
[It claims][3] that in spite of the "special relationship" with the UK, it is only ranked 15th of the countries tweeted about. It also says that Puerto Rico, Mexico and China are in fifth, fourth and third places respectively. According to The Economist North Korea is ranked in second place with 163 mentions.
A couple of years ago I read the excellent book "A Mathematician Reads the Newspaper" by John Allen Paulos; and I wonder how much of the daily news coverage can we check using the Wolfram Language. *In a future post I will speak about another project that we are doing with several members of this community that goes in a similar direction. We call it "computational conversations". With a bit of luck you might hear about it at the [Wolfram Technology Conference][4] later this year.*
Initial analysis
----------
It turns out that I have been monitoring @therealdonaldtrump's tweets using IFTTT since early 2017. I attach excel files to this post. To have a look at the first tweet we first set the directory and load the raw data files:
SetDirectory[NotebookDirectory[]]
dataraw = Import /@ FileNames["Trump*.xlsx"];
As the first file (without a number) will be read in last (alphabetical order), this is the first tweet data:
dataraw[[5, 1, 1]] // TableForm
![enter image description here][5]
It is from January 26th, 2017, a couple of days after his inauguration.
In oder to figure out which countries Mr Trump talks about we use the function TextCases, a recently updated function:
locations = TextCases[StringJoin[tweettexts], "LocationEntity" -> "Interpretation", VerifyInterpretation -> True];
I find
Length@locations
5768 locations; these will not only include direct mentions of countries but also locations within countries. These locations will be in Entity-form:
locations[[1;;20]]
![enter image description here][6]
Let's get that apart. First we make a list of all countries in the world:
purecountries = # -> {#} & /@ EntityList[EntityClass["Country", "Countries"]];
If we select all direct mentions of countries we obtain:
Select[locations, MemberQ[purecountries[[All, 1]], #] &] // Length
3624 mentions; if we exclude the 1349 mentions the US, we are left with 2275 country names. Despite our list starting with later tweets we obtain substantially more mentions of countries than The Economist (1,384). We can now generate a table of the mentions of all countries:
TableForm[Flatten /@ Transpose[{Range[Length[#] - 1], Delete[#, 5]}] &@({#[[1]], #[[2]]} & /@
Normal[ReverseSort[Counts[CommonName@(Select[locations, MemberQ[purecountries[[All, 1]], #] &])]]])]
![enter image description here][7]
(This is only the top of the list.) Note, that North Korea is missing, but will be very prominent in the next table.... Next we can check for "indirect" mentions of a country, i.e. Louvre would lead to a mention of France etc. We will find many more entities and will first generate a list of substitution rules:
countriesrules = # -> Check[GeoIdentify["Country", #], {#}] & /@ (Complement[DeleteDuplicates[locations], EntityList[EntityClass["Country", "Countries"]]]);
We will ignore the error messages for now. We can then generate a table that includes the "indirect" mentions, too:
TableForm[Flatten /@ Transpose[{Range[Length[#] - 1], Delete[#, 5]}] &@({#[[1]], #[[2]]} & /@
Normal[ReverseSort[Counts[CommonName@(DeleteMissing[Flatten[locations /. countriesrules]])]]])]
![enter image description here][8]
Note, that on rank 4 we find Media, which is not a country. It is easy to clean out, but I leave it in to show the performance of the code so far. We could now make typical representations such as GeoBubbleCharts:
GeoBubbleChart[Counts[DeleteMissing[Flatten[locations /. countriesrules]]], GeoBackground -> "Satellite"]
![enter image description here][9]
We can now make a BarChart (on a logarithmic scale) selecting "purecountries" like so:
BarChart[ReverseSort@<|
Select[Normal@
Counts[DeleteMissing[Flatten[locations /. countriesrules]]],
MemberQ[purecountries[[All, 1]], #[[1]]] &]|>,
ScalingFunctions -> "Log",
ChartLabels -> (Rotate[#, Pi/2] & /@
CommonName[
ReverseSortBy[
Select[Normal@
Counts[DeleteMissing[Flatten[locations /. countriesrules]]],
MemberQ[purecountries[[All, 1]], #[[1]]] &], Last][[All,
1]]]), PlotTheme -> "Marketing",
LabelStyle -> Directive[Bold, 15]]
![enter image description here][10]
We can also represent that on a world wide map:
styling = {GeoBackground -> GeoStyling["StreetMapNoLabels",
GeoStylingImageFunction -> (ImageAdjust@ColorNegate@ColorConvert[#1, "Grayscale"] &)],
GeoScaleBar -> Placed[{"Metric", "Imperial"}, {Right, Bottom}], GeoRangePadding -> Full, ImageSize -> Large};
GeoRegionValuePlot[
Log@<|Select[Normal@Counts[DeleteMissing[Flatten[locations /. countriesrules]]], MemberQ[purecountries[[All, 1]], #[[1]]] &]|>, Join[styling, {ColorFunction -> "TemperatureMap"}]]
![enter image description here][11]
Further analysis
----------
We can of course look at many other features of the tweets. One is a simple sentiment analysis. I am not at all convinced that the result of this attempt are useful or representing an actual pattern. But this is what we could do:
emotion[text_] := "Positive" - "Negative" /. Classify["Sentiment", text, "Probabilities"]
and then
tweetssentiments = emotion /@ tweettexts;
ListPlot[tweetssentiments, PlotRange -> All, LabelStyle ->
Directive[Bold, 15], AxesLabel -> {"tweet number", "sentiment"}]
![enter image description here][12]
Using a SmoothHistogram, we see a pattern of "extremes", negative, neutral, positive:
SmoothHistogram[tweetssentiments, PlotTheme -> "Marketing",
FrameLabel -> {"sentiment", "probablitiy"},
LabelStyle -> Directive[Bold, 16], ImageSize -> Large]
![enter image description here][13]
We can also ask for less relevant information, such as the colours mentioned in the tweets:
textcasesColor = TextCases[StringJoin[tweettexts], "Color" -> "Interpretation", VerifyInterpretation -> True]
![enter image description here][14]
So there is a lot of white, some black, red and green:
ReverseSort@Counts[textcasesColor]
![enter image description here][15]
Let's blend these colours together:
Graphics[{Blend[textcasesColor], Disk[]}]
![enter image description here][16]
We can also look for "profanity" in tweets:
textcasesProfanity = TextCases[StringJoin[tweettexts], "Profanity"];
and represent these tweets in a table:
Column[textcasesProfanity, Frame -> All]
![enter image description here][17]
It is not quite clear to my why some of the tweets are classified as containing profanity. For some tweets it is relatively obvious, I think.
Twitter handles
----------
Another interesting analysis is to look at the twitter handles that @therealdonaldtrump uses:
textcasesTwitterHandle = TextCases[StringJoin[tweettexts], "TwitterHandle"];
Here are counts of the 50 most common handles:
twitterhandles50 = Normal[(ReverseSort@Counts[ToLowerCase /@ textcasesTwitterHandle])[[1 ;; 50]]]
![enter image description here][18]
Last but not least we can make a BarChart of that:
BarChart[<|twitterhandles50|>, ChartLabels -> (Rotate[#, Pi/2] & /@ twitterhandles50[[All, 1]]),
LabelStyle -> Directive[Bold, 14]]
![enter image description here][19]
and to compare the same on a logarithmic scale:
BarChart[<|twitterhandles50|>, ChartLabels -> (Rotate[#, Pi/2] & /@ twitterhandles50[[All, 1]]),
LabelStyle -> Directive[Bold, 14], ScalingFunctions -> "Log"]
![enter image description here][20]
A little word cloud
----------
Just to finish off we will generate a little word cloud like so:
allwords = Flatten[TextWords /@ tweettexts];
WordCloud[ToLowerCase /@ DeleteCases[DeleteStopwords[ToString /@ allwords], "&amp;"]]
![enter image description here][21]
The cloud picks up on "witch hunt" and "collusion", "@foxandfrieds" and "Russia", "fake", "border" as well as other terms that indeed are relatively prominent in the media.
Conclusion
----------
The main objective of this was to look try to reproduce at least qualitatively the results of the twitter analysis of @therealdonaldtrump's tweets by The Economist using the Wolfram Language. We have been using a slightly different period of the tweets. We have been looking at direct mentions and "indirect" ones. I have not made any manual comparison of the results. I am not sure whether the recognition has worked and I only post it as a first cursory analysis.
It was relatively easy to go beyond the analysis and look at other features of the tweets, too.
[1]: https://www.economist.com
[2]: https://twitter.com/TheEconomist/status/1145467208950329344
[3]: https://www.economist.com/graphic-detail/2019/06/04/the-world-according-to-donald-trump
[4]: http://www.wolfram.com/events/technology-conference/2019/
[5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1000.12.59.png&userId=48754
[6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1000.27.41.png&userId=48754
[7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1000.34.11.png&userId=48754
[8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1000.41.34.png&userId=48754
[9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1000.43.14.png&userId=48754
[10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1000.45.38.png&userId=48754
[11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1001.24.25.png&userId=48754
[12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1000.53.33.png&userId=48754
[13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1000.55.22.png&userId=48754
[14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1001.05.39.png&userId=48754
[15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1001.07.12.png&userId=48754
[16]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1001.08.07.png&userId=48754
[17]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1001.09.33.png&userId=48754
[18]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1001.12.15.png&userId=48754
[19]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1001.13.26.png&userId=48754
[20]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1001.14.50.png&userId=48754
[21]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1001.33.04.png&userId=48754Marco Thiel2019-07-10T00:40:42ZModelling Ambulance Coverage Using Isochrones
https://community.wolfram.com/groups/-/m/t/1642194
Currently public health officials measure ambulance coverage using a simple radius (for urban areas this radius is typically 2.5 miles). However, using a radius to model coverage doesn’t give a realistic representation of expected ambulance response times. Modeling coverage using isochrones seems like the most natural fit to accurately measure response times. Isochrones represent all locations that can be travelled to within a certain time limit. In accordance with the Office of the Inspector General’s recommended response times for emergency medical services, we built isochrones of a 5 minute ‘radius’. We take an area located on the South Side of Chicago and subdivide it into potential points we can travel to:
NL1 = Subdivide[41.64952897794792`, 41.81247732431524`, 20];
NL2 = Subdivide[-87.71329065894878`, -87.55250871202725`, 20];
grid = Tuples[{NL1, NL2}];
geogrid = Thread[GeoPosition[#] &@grid];
geogridplot = GeoListPlot[geogrid, PlotStyle -> {Lighter@Cyan, Thin},
GeoBackground -> GeoStyling["StreetMapNoLabels",
GeoStylingImageFunction -> (ImageAdjust@Darker@ColorNegate@ColorConvert[#1, "Grayscale"] &)]];
We select the following ambulance location to build an isochrones for:
ambl = GeoPosition[{41.68740625454284`, -87.62413685881735`}];
ambulancesite= GeoListPlot[ambl, PlotStyle -> {Lighter@Red, Thick}];
Show[geogridplot, ambulancesite]
![enter image description here][1]
The red point is our ambulance site and the blue points are our grid points.
We start by calculating the distance from our chosen ambulance location to each of the points on our grid using the built in `TravelTime[]` function:
tt = TravelTime[{ambl, #}] & /@ geogrid;
We send the quantity `$Failed` to an arbitrary travel time greater than 5 minutes then convert the travel time in minutes to an integer quantity given in seconds.
tt = tt /. {$Failed -> Quantity[100, "Minutes"]};
tt = QuantityMagnitude[UnitConvert[tt]];
Points we cannot travel to within 5 minutes (300 seconds) are coded as 0 and points we can travel to within our time limit are coded as 1.
tt1= tt /. n_Integer /; n < 301 -> 1;
tt0 = tt1 /. n_Integer /; n > 300 -> 0;
coordinates1 = DeleteCases[tt0*grid,0]
`coordinates1` only contains points we can reach from our ambulance site within 5 minutes. Now, we want to visualize our isochrones:
isotest = TravelDirections[{ambl, #}] & /@ coordinates1;
GeoGraphics[Style[Line[isotest], Thick, Lighter@Red], {GeoBackground -> GeoStyling["StreetMapNoLabels",
GeoStylingImageFunction -> (ImageAdjust@Darker@ColorNegate@ColorConvert[#1, "Grayscale"] &)]}]
![enter image description here][2]
This is a rough approximation of all points we can travel to within 5 minutes from our starting point. We can refine our approximation by taking the CoordinateBound[] of the points from that we can travel to within 320 seconds from our initial travel times-`tt`-and then subdivide the region to get a new grid of potential points. Here we are allowing ourselves a 20 second error margin to make sure we don’t miss any points we can travel to.
ltt = tt /. n_Integer /; n < 321 -> 1;
Ott = ltt /. n_Integer /; n > 320 -> 0;
co320= Ott*grid;
co320 = DeleteCases[co320, {0., 0.}];
CoordinateBounds[co320]
{{41.6495, 41.7147}, {-87.6651, -87.5766}}
Next we create a separate grid to run the TravelTime[] function over:
I1 = Subdivide[41.64952897794792`, 41.71470831649485`, 31];
I2 = Subdivide[-87.66505607487233`, -87.57662600406547`, 31];
IG = Tuples[{I1, I2}];
Subdividing this coordinate bound gives us 1024 points we can travel to within 320 seconds. Now, we run the exact same procedure above to better refine the isochrones:
IG = Thread[GeoPosition[#] &@IG];
itt = TravelTime[{ambl, #}] & /@ IG;
itt= itt /. {$Failed -> Quantity[100, "Minutes"]};
itt = QuantityMagnitude[UnitConvert[itt]];
lit = itt /. n_Integer /; n < 301 -> 1;
Oit = lit /. n_Integer /; n > 300 -> 0;
coordinates2 = Oit*IG;
coordinates2= DeleteCases[coordinates2, 0];
iso = TravelDirections[{ambl, #}] & /@ coordinates2;
Finally we are able to map our improved isochrones and compare the difference in estimating ambulance coverage with a simple radius and isochrones.
GeoGraphics[{{Blue, GeoDisk[ambl, Quantity[2.5, "Miles"]]},
Style[Line[iso], Thick, Lighter@Red]}, {GeoBackground ->
GeoStyling["StreetMapNoLabels",
GeoStylingImageFunction -> (ImageAdjust@
Darker@ColorNegate@ColorConvert[#1, "Grayscale"] &)]}]
![enter image description here][3]
Using a simple radius overestimates coverage in some areas and underestimates coverage in others.
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=city.png&userId=1598258
[2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=iso1.png&userId=1598258
[3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=iso2.png&userId=1598258William Rudman2019-03-28T20:38:33Z