https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Graphs and Networks sorted by most viewed. https://community.wolfram.com/groups/-/m/t/2593151 **Introducing our brand new YouTube channel, [Wolfram R&D][1]! Our channel features livestreams, behind-the-scenes creator presentations, insider videos, and more.** ---------- Join us for the unique Wolfram R&D livestreams on [Twitch][2] and [YouTube][3] led by our developers! You will see **LIVE** stream indicators on these channels on the dates listed below. The live streams provide tutorials and behind the scenes look at Mathematica and the Wolfram Language directly from developers. Join our livestreams every Wednesday at 11 AM CST and interact with developers who work on data science, machine learning, image processing, visualization, geometry, and other areas. ---------- ⭕ **UPCOMING** EVENTS - Jan 29 -- Reinforcement Learning Applied to Feedback Control with [Suba Thomas][61] ---------- ✅ **PAST** EVENTS - April 24 -- [FeynCalc][60] - April 3 -- [Explore the Total Solar Eclipse of April 2024][59] - Mar 22 -- [20 Years of xAct Tensor Computer Algebra][58] - Feb 28 -- [Zero Knowledge Authentication][57] - Jan 17 -- [Nutrients by the Numbers][56] - Dec 13 -- [Understanding Graphics][55] - Oct 18 -- [Overview of Number Theory][54] - Sep 27 -- [QMRITools: Processing Quantitative MRI Data][52] - Sep 13 -- [Make High Quality Graph Visualization][51] - Sep 6 -- [Insider's View of Graphs & Networks][53] - Aug 30 -- [Labeling Everywhere][49] - Aug 22 -- [Equation Generator for Equation-of-Motion Coupled Cluster Assisted by CAS][48] - Aug 16 -- [Foreign Function Interface][4] - July 26 -- [Modeling Fluid Circuits][6] - July 19 -- [Geocomputation][5] - July 5 -- [Protein Visualization][7] - Jun 14 -- [Chat Notebooks bring the power of Notebooks to LLMs][8] - May 31-- [Probability and Statistics: Random Sampling][9] - May 24 -- [Problem Solving][10] - May 17 -- [The state of Optimization][11] - May 10 -- [Building a video game with Wolfram notebooks][12] - April 26 -- [Control Systems: An Overview][13] - April 19 -- [MaXrd: A crystallography package developed for research support][14] - April 5th -- [Relational database in the Wolfram Language][15] - Mar 29th -- [Build your first game in the Wolfram Language with Unity game engine] [16] - Mar 22nd -- [Everything to know about Mellin-Barnes Integrals - Part II][17] - Mar 15th -- [Building your own Shakespearean GPT - a ChatGPT like GPT model][18] - Mar 8th -- [Understand Time, Date and Calendars][19] - Mar 1st -- [Introducing Astro Computation][20] - Feb 22nd -- [Latest features in System Modeler][21] - Feb 15th -- [Everything to know about Mellin-Barnes Integrals][22] - Feb 8th -- [Dive into Video Processing][23] - Feb 1st -- [PDE Modeling][24] - Jan. 25th -- [Ask Integration Questions to Oleg Marichev][25] - Jan. 18th -- [My Developer Tools][26] - Jan. 11th -- [Principles of Dynamic Interfaces][27] - Dec. 14th -- [Wolfram Resource System: Repositories & Archives][28] - Dec. 7th -- [Inner Workings of ImageStitch: Image Registration, Projection and Blending][29] - Nov. 30th -- [Q&A for Calculus and Algebra][30] - Nov. 23rd -- [xAct: Efficient Tensor Computer Algebra][31] - Nov. 16th -- [Latest in Machine Learning][32] - Nov. 9th -- [Computational Geology][33] - Nov. 2nd -- [Behind the Scenes at the Wolfram Technology Conference 2022][34] - Oct 26th -- [Group Theory Package (GTPack) and Symmetry Principles in Condensed Matter][35] - Oct 12th -- [Tree Representation for XML, JSON and Symbolic Expressions][36] - Oct. 5th -- [A Computational Exploration of Alcoholic Beverages][37] - Sept. 28th -- [Q&A with Visualization & Graphics Developers][38] - Sept. 14th -- [Paclet Development][39] - Sept. 7th -- [Overview of Chemistry][40] - Aug. 24th -- [Dive into Visualization][41] - Aug. 17th -- [Latest in Graphics & Shaders][42] - Aug. 10th -- [What's new in Calculus & Algebra][43] > **What are your interests? Leave a comment here on this post to share your favorite topic suggestions for our livestreams.** **Follow us on our live broadcasting channels [Twitch][44] and [YouTube][45] and for the up-to-date announcements on our social media: [Facebook][46] and [Twitter][47].** [1]: https://wolfr.am/1eatWLcDA [2]: https://www.twitch.tv/wolfram [3]: https://wolfr.am/1eatWLcDA [4]: https://www.youtube.com/watch?v=C82NHpy7D6k [5]: https://community.wolfram.com/groups/-/m/t/2985580 [6]: https://community.wolfram.com/groups/-/m/t/2982197 [7]: https://community.wolfram.com/groups/-/m/t/2982114 [8]: https://youtu.be/ZqawtrWwE0c [9]: https://community.wolfram.com/groups/-/m/t/2946101 [10]: https://community.wolfram.com/groups/-/m/t/2925156 [11]: https://community.wolfram.com/groups/-/m/t/2921756 [12]: https://community.wolfram.com/groups/-/m/t/2918746 [13]: https://community.wolfram.com/groups/-/m/t/2917597 [14]: https://community.wolfram.com/groups/-/m/t/2911327 [15]: https://community.wolfram.com/groups/-/m/t/2907390 [16]: https://community.wolfram.com/groups/-/m/t/2921593 [17]: https://community.wolfram.com/groups/-/m/t/2861119 [18]: https://community.wolfram.com/groups/-/m/t/2847286 [19]: https://community.wolfram.com/groups/-/m/t/2851575 [20]: https://community.wolfram.com/groups/-/m/t/2852934 [21]: https://community.wolfram.com/groups/-/m/t/2842136 [22]: https://community.wolfram.com/groups/-/m/t/2838335 [23]: https://community.wolfram.com/groups/-/m/t/2827166 [24]: https://community.wolfram.com/groups/-/m/t/2823264 [25]: https://community.wolfram.com/groups/-/m/t/2821053 [26]: https://youtu.be/istKGqpDUsw [27]: https://community.wolfram.com/groups/-/m/t/2777853 [28]: https://youtu.be/roCkXVkDuLA [29]: https://youtu.be/pYHAz-NatXI [30]: https://youtu.be/r7Hjdr_D7c4 [31]: https://community.wolfram.com/groups/-/m/t/2713818 [32]: https://community.wolfram.com/groups/-/m/t/2705779 [33]: https://community.wolfram.com/groups/-/m/t/2701172 [34]: https://youtu.be/UrM-OBu3H9o [35]: https://community.wolfram.com/groups/-/m/t/2678940 [36]: https://community.wolfram.com/groups/-/m/t/2649407 [37]: https://community.wolfram.com/groups/-/m/t/2635049 [38]: https://community.wolfram.com/groups/-/m/t/2618033 [39]: https://community.wolfram.com/groups/-/m/t/2616863 [40]: https://community.wolfram.com/groups/-/m/t/2613617 [41]: https://community.wolfram.com/groups/-/m/t/2605432 [42]: https://community.wolfram.com/groups/-/m/t/2600997 [43]: https://community.wolfram.com/groups/-/m/t/2596451 [44]: https://www.twitch.tv/wolfram [45]: https://wolfr.am/1eatWLcDA [46]: https://www.facebook.com/wolframresearch [47]: https://twitter.com/WolframResearch [48]: https://www.youtube.com/live/ElP55ZILxPw?si=nsAPOQ3u-RbvuGKX [49]: https://community.wolfram.com/groups/-/m/t/3007543 [50]: https://community.wolfram.com/web/charlesp [51]: https://community.wolfram.com/groups/-/m/t/3019288 [52]: https://www.youtube.com/live/KM1yWHRrF2k?si=g2R7rHB2IinVRpo6 [53]: https://community.wolfram.com/groups/-/m/t/3009184 [54]: https://community.wolfram.com/groups/-/m/t/3064700 [55]: https://community.wolfram.com/groups/-/m/t/3084291 [56]: https://community.wolfram.com/groups/-/m/t/3104670 [57]: https://community.wolfram.com/groups/-/m/t/3164204 [58]: https://youtube.com/playlist?list=PLdIcYTEZ4S8TSEk7YmJMvyECtF-KA1SQ2&si=paXZHs0ZzGdB7y1y [59]: https://youtube.com/playlist?list=PLdIcYTEZ4S8RyjEB7JSAsGerbYHl5xXeJ&si=xkNtkIDvKHFWHVmD [60]: https://youtu.be/KUWK19Gx2LE?si=qbKISbL8FtvweSWo [61]: https://community.wolfram.com/web/subat Charles Pooh 2022-08-05T21:37:19Z https://community.wolfram.com/groups/-/m/t/434022 *Images / animations are large, **wait till they load**. The best part IMHO is at the end. Huge table is NOT the end.* ---------- A color can be a hard thing to pinpoint. A harder question, perhaps: **Do visually close colors evoke close semantic descriptions?** Is **electric lime** close to **goblin grin**? That’s not RGB… but these are “real colors”. At least according to “public color poll” run by ever-inventive creator of XKCD comic Randall Munroe. And from 222,500 user sessions and over five million colors we finally can pose a question: if visual similarity of colors - like this graph (I will show how to build it from XKCD data later): ![enter image description here][1] can be used to define "semantic proximity" of subjective color descriptions ...like these ones (also [from XKCD data][2]): ![enter image description here][3] ![enter image description here][4] Well, we will investigate, or at least try to pinpoint, visual similarity to comprehend the semantic one (if there is any). BTW, this is not a typo, - ladies do prefer to use “camel” for color! And I am not going to comment about what type of glasses gentlemen see the world through. So what does programming have to do with this? Patience, there is a huge chart and a network - way down this post – result of some coding… and probably a few more jokes. When Randall Munroe published the poll data there were a few efforts to visualize results. [Simple table by XKCD][5] like this ![enter image description here][6] was a bit disorienting for me because colors were visually random. Data Pointed efforts were excellent. But [first one][7] had too few most-popular names (while stunning): [![enter image description here][8]][9] [The second one][10], quite an [interactive marvel][11], had some tiny points which were hard to see and easy to miss with good names: [![enter image description here][12]][13] I wanted to browse all ~1000 names but in a sort of consistent color-wise way. **The main point being, when i see a "goblin green" color, I would like neighboring colors to be similar, so I can see which names should also be close semantically. Basically I wanted to compare names of similar colors.** Let’s import data and see a sample: data = Import["http://xkcd.com/color/rgb.txt", "Data"][[All, 1 ;; 2]]; data // Length data[[;; 4]] // Column `949 {{{"cloudy blue", "#acc2d9"}}, {{"dark pastel green", "#56ae57"}}, {{"dust", "#b2996e"}}, {{"electric lime", "#a8ff04"}}` Note, colors are given as hexadecimal HTML codes. We can use Interpreter to get colors in WL format, say RGB: clrs = Interpreter["Color"][data[[All, 2]]]; Multicolumn[clrs, 30] ![enter image description here][14] We, of course, could just throw all the points on a chromatic diagram: ChromaticityPlot[{clrs, "RGB"}, PlotTheme -> "Detailed", Appearance -> {"VisibleSpectrum", "Wavelengths" -> True}] ![enter image description here][15] ...or in 3D ChromaticityPlot3D[{clrs, "RGB"}, PlotTheme -> "Marketing", Appearance -> "VisibleSpectrum", SphericalRegion -> True] ![enter image description here][16] ...but that of course would not get me anywhere with readability of color names. So I decided to do the simplest thing - a table. Columns would arrange colors in one way while rows in another. This won't be perfect, but let's try it. For example in [LUV color space][17] there are 3 parameters: - L - lightness, approximate luminance - U - color - V - color LUV is a color space designed to have perceptual **uniformity**; i.e. equal changes in its components will be perceived by a human to have equal effects. I hope this uniformity will help me to rearrange the colors. LUV is extensively used for applications such as computer graphics which deal with colored lights and is device independent. Let's get data in a convenient format: dataP = MapAt[ColorConvert[Interpreter["Color"][#], "LUV"] &, #, 2] & /@ data; dataP[[;; 5]] // Column ![enter image description here][18] I will sort by abstract colors U and V and sacrifice lightness L to keep things simple and 2-dimensional. 2D sorting already will be helpful. Once **data are sorted according to U** dataPA = SortBy[dataP, #[[2, 2]] &]; we ragged-partition them in 10 columns and **sort each column according to V**: dataPAB = SortBy[#, #[[2, 3]] &] & /@ Partition[dataPA, 10, 10, 1, {}]; dataPAB[[;; 5, ;; 5]] // TableForm ![enter image description here][19] Note the tricky syntax for `Partition` to keep partitioning ragged and not cut off a short remaining column. Now I will just build a grid where cells are rectangles of color with the color name written inside. But here is a tricky part: text color should be in contrast to the color of cell background, to be readable. Good that we have ColorNegate! We can use ColorNegate[x] when cell color is x - cool! ...except when cell color is gray because ColorNegate[Gray] // InputForm `GrayLevel[0.5]` Hmmm... Well let's be inventive. When `ColorDistance` of a cell-color too close to `Gray` - we'll simply use `White` for text. Define: rect[{x_, y_}] := Framed[Style[x, 10, If[ColorDistance[ColorNegate[y], Gray] < .2, White, ColorNegate[y]]], Background -> y, ImageSize -> {80, 50}] Check: rect@{"speechless green", Green} ![enter image description here][20] Great, we now ready. Behold, read, and wonder (right-click and "open image in new tab" to see a bigger version). Do not forget - there is more stuff after this table. Grid[ParallelMap[rect, dataPAB, {2}], Spacings -> {0, 0}] ![enter image description here][21] Well, could there a be a better or different way to visualize relationships? What about a network graph - judging by [social analytics approaches][22] - they are the best to represent relationships. Let's make a clean cut and get the data again: data = Import["http://xkcd.com/color/rgb.txt", "Data"][[All, 1 ;; 2]]; And we turn strings of color descriptions into WL format colors with Interpreter again: data = Reverse[MapAt[Interpreter["Color"], #, 2]] & /@ data; data[[;; 5]] // Column ![enter image description here][23] Now, like on Facebook - you have friends and they have friends and so on - we need to find closest friends of each color. We can use `ColorDistance` for that that utilizes many measures, for example `Euclidean` distance in `LABColor` and such. Let's define our distance function: neco[{u_, v_}, {x_, y_}] := ColorDistance[u, x] Now in WL we have an awesome function `Nearest` that can operate on any objects to deduce the closest to it objects: neig[c_] := Nearest[DeleteCases[data, c], c, {All, .16}, DistanceFunction -> neco] where `{All, .16}` means *among all objects find closest within radius 0.16 as given by `DistanceFunction`*. `DeleteCases` is needed exclude the original object as its own friend. Check: ![enter image description here][24] This function will connect the original color and its closest friends within 0.16 measure of `DistanceFunction` edgs[v_] := v <-> # & /@ neig[v] Check: ![enter image description here][25] Noticed the trick with `Sort`? `Sort` will flip the edges to orient `b<->a` as `a<->b` so we can delete duplicates using `Union` when building all edges between all colors and their friends: edgsALL = Union[Sort /@ Flatten[ParallelMap[edgs, data], 1]]; To get a simple color-proximity `Graph` define a `VertexLabels` function: panelLabel[lbl_] := lbl[[1]] And now behold: g = Graph[data, edgsALL, VertexLabels -> Table[i -> Placed[{i}, Center, panelLabel], {i, data}], EdgeStyle -> Opacity[.2], EdgeShapeFunction -> "Line", VertexSize -> 0, ImageSize -> 900] ![enter image description here][26] To build a large scale browseable network with readable labels define new label function: panelLabel[lbl_] := Panel[Style[lbl[[2]], 14, Bold, If[ColorConvert[lbl[[1]], "GrayLevel"][[1]] < .5, White, Black]], FrameMargins -> 0, Background -> lbl[[1]]] Instead of negating the color of text (as we did in the huge table) we make it `White` if `GrayLevel` of background is `< 0.5` and Black if it is `> 0.5`. A different approach. Check: ![enter image description here][27] Perfect. Now the monster network: g = Graph[data, edgsALL, VertexLabels -> Table[i -> Placed[{i}, Center, panelLabel], {i, data}], EdgeStyle -> Opacity[.2], EdgeShapeFunction -> "Line", VertexSize -> 0, ImageSize -> 10000]; To browse it open [**==> THIS LINK <==**][28] in a **NEW TAB** and zoom in/out. It will look something like this: ![enter image description here][29] Interesting part is why did we chose **radius 0.16**? Two words - [percolation theory][30]. **Radius 0.16** for XKCD data serves as [percolation threshold][31] much below which the network has a lot of disconnected components and much above which the network is "overconnected" complete `Graph`. The former is lack of information and the later is "too much" info for meaningful sharp description. My intuition is that percolation threshold is the golden middle that allows for concise but precise definitions. You can experiment lowering it and increasing it to see how network under- and over- connects. Percolation threshold is that moment when you can get from one description to another and then next one and get to any other description. Using association chains you can deduce deeper connections among remote meanings **in the whole network**. This is of course is speculative and arguable. Let me know if you are familiar with relevant research or have an opinion. And now using percolation threshold we can define new colors based on old descriptions: Labeled[Grid[neig[{#, ""}], Frame -> All], Row[{"New clor ", Graphics[{#, Disk[]}, ImageSize -> 30], " is like"}], Top] &@RandomColor[] ![enter image description here][32] Concise (much less than full ~1000 descriptors) but precise (you "got the feeling"). Now what is next? It would be really great to make a "machine" have an imagination and form its own new color descriptors. How? - not sure but probably running [WL machine learning][33] on some large color-related corpora. When I figure it out - I will write a continuation. Or maybe you will? [1]: /c/portal/getImageAttachment?filename=lablelessnet.png&userId=11733 [2]: http://blog.xkcd.com/2010/05/03/color-survey-results/ [3]: /c/portal/getImageAttachment?filename=female_colors.gif&userId=11733 [4]: /c/portal/getImageAttachment?filename=male_colors.gif&userId=11733 [5]: http://xkcd.com/color/rgb/ [6]: /c/portal/getImageAttachment?filename=assorted_colors.png&userId=11733 [7]: http://www.datapointed.net/2010/06/xkcd-color-name-strata/ [8]: /c/portal/getImageAttachment?filename=color_name_strata_l.jpg&userId=11733 [9]: http://www.datapointed.net/2010/06/xkcd-color-name-strata/ [10]: http://www.datapointed.net/2010/09/men-women-color-names/ [11]: http://www.datapointed.net/visualizations/color/men-women-color-names-d3/ [12]: /c/portal/getImageAttachment?filename=2015-02-02_16-30-13.png&userId=11733 [13]: http://www.datapointed.net/visualizations/color/men-women-color-names-d3/ [14]: /c/portal/getImageAttachment?filename=asd3q4tewrhsfghbdas453Q.png&userId=11733 [15]: /c/portal/getImageAttachment?filename=dsfg4wrtyhgfsgw45temyj.png&userId=11733 [16]: /c/portal/getImageAttachment?filename=asdd43gsrty54wyrht.gif&userId=11733 [17]: http://reference.wolfram.com/language/ref/LUVColor.html [18]: /c/portal/getImageAttachment?filename=2015-02-02_17-22-39.png&userId=11733 [19]: /c/portal/getImageAttachment?filename=ScreenShot2015-02-02at5.29.43PM.png&userId=11733 [20]: /c/portal/getImageAttachment?filename=ScreenShot2015-02-02at5.44.37PM.png&userId=11733 [21]: /c/portal/getImageAttachment?filename=sdf34qeadfty65tyejnfsgd.png&userId=11733 [22]: http://en.wikipedia.org/wiki/Social_network [23]: /c/portal/getImageAttachment?filename=ScreenShot2015-02-03at9.00.52AM.png&userId=11733 [24]: /c/portal/getImageAttachment?filename=ScreenShot2015-02-03at9.10.19AM.png&userId=11733 [25]: /c/portal/getImageAttachment?filename=ScreenShot2015-02-03at9.13.45AM.png&userId=11733 [26]: /c/portal/getImageAttachment?filename=lablelessnet.png&userId=11733 [27]: /c/portal/getImageAttachment?filename=ScreenShot2015-02-03at9.20.41AM.png&userId=11733 [28]: http://community.wolfram.com/c/portal/getImageAttachment?filename=awrsdfsd4345gsgs.jpg&userId=11733 [29]: /c/portal/getImageAttachment?filename=ezgif.com-optimize.gif&userId=11733 [30]: http://en.wikipedia.org/wiki/Percolation_theory [31]: http://en.wikipedia.org/wiki/Percolation_theory [32]: /c/portal/getImageAttachment?filename=ScreenShot2015-02-03at10.31.32AM.png&userId=11733 [33]: http://www.wolfram.com/mathematica/new-in-10/machine-learning/ Vitaliy Kaurov 2015-02-02T23:52:47Z https://community.wolfram.com/groups/-/m/t/1907703 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=animation.gif&userId=24497 [2]: https://www.wolframcloud.com/obj/111b7fc9-47f8-4d2e-90ff-fe71265746fd Christopher Wolfram 2020-03-25T06:40:12Z https://community.wolfram.com/groups/-/m/t/932548 #Introduction I recently saw a TV show set at Four Corners USA, the point where Utah, Colorado, Arizona, and New Mexico meet: ![enter image description here][1] It made me wonder how frequent 4 or more geographical borders meet at one point. According to [Wikipedia][2], 4 borders meeting at a point is called a ***quadripoint***, 5 borders meeting is called a ***quintipoint***, and in general it's called a ***multipoint***. The entry only lists one quintipoint and goes on to say > Perhaps a dozen quintipoints of various levels of geopolitical subdivisions are scattered around the world; This piqued my interest to find all multipoints, using the Wolfram Language. -------- #Results Before I give the details on how to detect multipoints, I'd like to showcase the results. ###Summary - Since borders are not always precise (or even well defined at times), I allowed for an error up to ~100 meters when classifying points. - The polygons were obtained from the `"Country"` and `"AdministrativeDivision"` `Entity` types (about 40,000 in total). - There are a total of **724 quadripoints** in this dataset. - There are a total of **13 quintipoints** in this dataset. - There is **1 *10-point*** in this dataset! - There are **only 6 multipoints** in the dataset whose regions *don't* share the same parent region. ###Quadripoints With **724 quadripoints**, there are too many to list here, but here are a few interesting ones. - The only countries to form a quadripoint are **Namibia, Botswana, Zambia, and Zimbabwe**. ![enter image description here][3] - There are a considerable amount of **counties in Iowa and Texas** that are apart of multiple quadripoints, i.e. more than one corner is a quadripoint. This is because they are roughly arranged in a rectangular grid. ![enter image description here][4] - There were only 6 quadripoints found whose parent regions differ: ![enter image description here][5] - Here's a visual summary of all quadripoints found (note the level 3 regions were heavily thickened to become visible): ![enter image description here][6] ###Quintipoints Here are all **13 quintipoints** found: - **Saint Kitts and Nevis**: Saint George Gingerland - Saint James Windward - Saint John Figtree - Saint Paul Charlestown - Saint Thomas Lowland - **Boyaca, Colombia**: Chinavita - Garagoa - Miraflores - Ramiriquí - Zetaquirá - **Counties in Florida, USA**: Glades - Hendry - Martin - Okeechobee - Palm Beach - **Usulutan, El Salvador**: California - Ozatlán - Santa Elena - Tecapán - Usulután - **Arequipa, Arequipa, Peru**: Alto Selva Alegre - Cayma - Chiguata - Miraflores - San Juan de Tarucani - **Cuenca, Azuay, Ecuador**: Chiquintad - Cuenca - Ricaurte - Sidcay - Sinicay - **Pea Reang, Prey Vêng, Cambodia**: Kampong Popil - Mesa Prachan - Prey Sralet - Reab - Roka - **Rieti, Lazio, Italy**: Borgo Velino - Castel Sant' Angelo - Cittaducale - Micigliano - Rieti - **Cosenza, Calabria, Italy**: Marano Marchesato - Marano Principato - Rende - San Fili - San Lucido - **Napoli, Campania, Italy**: Boscotrecase - Ercolano - Ottaviano - Torre Del Greco - Trecase - **Savona, Liguria, Italy**: Bardineto - Boissano - Giustenice - Loano - Pietra Ligure - **Torino, Piemonte, Italy**: Cuceglio - Mercenasco - Montalenghe - Scarmagno - Vialfrè - **Viterbo, Lazio, Italy**: Bolsena - Capodimonte - Gradoli - Montefiascone - San Lorenzo Nuovo As you can see, Italy takes the cake with 6 quintipoints! Here's a visual of these quintipoints, along with the error allowing them to be classified as such: ![enter image description here][7] ###A Near 6-point Notice in the top right map above, it looks like there is room for one more region in Viterbo, Lazio, Italy, which would make it a 6-point. Here's the 6th region (Grotte Di Castro) in black: ![enter image description here][8] It turns out Grotte Di Castro is about 700 meters from the quintipoint, making this only a ***near* 6-point**: ![enter image description here][9] ###10-point As mentioned in the [Wikipedia entry][10], there is a 10-point in Italy at the summit of [Mount Etna][11]: - **Catania, Sicily, Italy**: Adrano - Belpasso - Biancavilla - Bronte - Castiglione Di Sicilia - Maletto - Nicolosi - Randazzo - Sant' Alfio - Zafferana Etnea ![enter image description here][12] ###Allowing for more error If we allow for more error, we can find ***near-multipoints*** - regions that almost have a multipoint, but clearly don't. For example, there is a near-quintipoint in Texas, USA: ![enter image description here][13] -------- #Code The idea to find multipoints within a collection of regions is as follows: 1. Obtain the `Polygon` for each region. 2. For each pair of regions, if there's a vertex from one of the polygons which is "close" to the other, mark these regions as touching. `RegionDistance` can be used for this. 3. The relation of touching between pairs forms an adjacency matrix. From this, form a `Graph` and use `FindClique` to find all multipoints in this collection. Here is code that does just that: discretize[Polygon[pts_?MatrixQ]] := MeshRegion[pts, Polygon[Range[Length[pts]]]] discretize[Polygon[pts_?(VectorQ[#, MatrixQ] &)]] := With[{pts2 = Select[pts, Length[#] > 2 &]}, MeshRegion[Join @@ pts2, Polygon[Range[# + 1, #2] & @@@ Partition[Prepend[Accumulate[Map[Length, pts2]], 0], 2, 1]]] ] discretize[expr_] := With[{mr = DiscretizeGraphics[Graphics[expr]]}, mr /; MeshRegionQ[mr] ] discretize[_] = $Failed; polyLookup = discretize /@ (Join[ EntityValue["Country", "Polygon", "EntityAssociation"], EntityValue["AdministrativeDivision", "Polygon", "EntityAssociation"] ] /. GeoPosition -> Identity); MultiPoints[divs_List, n_] /; Length[divs] < n = {}; MultiPoints[divs_List, n_] := Block[{polys, disj, cands}, polys = polyLookup /@ divs; ( disj = Boole[Outer[CoordinateNear, polys, polys]] - IdentityMatrix[Length[divs]]; ( cands = FindClique[AdjacencyGraph[divs, disj], {n, Infinity}, All]; resolveMultiPoints[cands, AssociationThread[divs, polys]] ) /; MatrixQ[disj, IntegerQ] ) /; VectorQ[polys, MeshRegionQ] ] MultiPoints[___] = {}; $tol = 0.001; CoordinateNear[mr1_, mr2_, tol_:$tol] := With[{d = {{-tol, tol}, {-tol, tol}}}, And[ NoneTrue[Transpose[{d+RegionBounds[mr1], d+RegionBounds[mr2]}], #1[[2,1]] > #1[[1,2]] || #1[[1,1]] > #1[[2,2]]&], Min[RegionDistance[mr1, MeshCoordinates[mr2]]] < tol ] ] resolveMultiPoints[{}, _] = {}; resolveMultiPoints[cands_List, passoc_?AssociationQ] := Select[cands, MultiPointQ[#, passoc]&] MultiPointQ[cands_, passoc_?AssociationQ, tol_:$tol] := Block[{coords, mrs}, mrs = passoc /@ cands; coords = Union @@ MeshCoordinates /@ mrs; Or @@ Thread[And @@ (Thread[RegionDistance[#, coords] < tol]& /@ mrs)] ] Now here's all multipoints formed from countries: ![enter image description here][14] Now to explore all cases, we can start off by looking for multipoints in all subdivisions of a given region, e.g. given Florida, find all multipoints within the counties of Florida. This can be achieved by building a hierarchical graph connecting countries and administrative divisions. Then for a given region, this graph can be used to find all subdivisions and the above code can be used to find the multipoints. ad = AdministrativeDivisionData[]; pr = EntityValue["AdministrativeDivision", "ParentRegion"]; $ADNetwork = Graph[Join[ Thread["NullPointer" -> EntityList["Country"]], DeleteCases[Thread[pr -> ad], Rule[_Missing, _]] ]]; ChildrenMultiPoints[reg_] := ChildrenMultiPoints[reg, 4] ChildrenMultiPoints[reg_, o___] := MultiPoints[Rest[VertexOutComponent[$ADNetwork, reg, 1]], o] ![enter image description here][15] Lastly, to cover all cases we need to consider sets of regions that have differing parent regions. To do this, for a given parent region $P$, first find all other regions $R_i$ (on the same level) that touch this region. Then simply run `MultiPoints` on all subdivisions in $P \cup R_i$. I omit this code here, as there were only 6 instances that came out of this case. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=7535fourcorners.png&userId=46025 [2]: https://en.wikipedia.org/wiki/Quadripoint [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=countryquadripoint.png&userId=46025 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2008squarequadripoints.png&userId=46025 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=crossregionquadripoints.png&userId=46025 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=allquadripoints.png&userId=46025 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4697quintipoints.png&userId=46025 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=8873almostsixpoint.png&userId=46025 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=9086almostsixpointzoom.png&userId=46025 [10]: https://en.wikipedia.org/wiki/Quadripoint#Multipoints_of_greater_numerical_complexity [11]: https://en.wikipedia.org/wiki/Mount_Etna#Geopolitical_oddity [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3719tenpoint.png&userId=46025 [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4645almostquintpoint.png&userId=46025 [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2016-10-0117.18.37.png&userId=46025 [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2016-10-0117.27.16.png&userId=46025 Greg Hurst 2016-10-01T22:56:22Z https://community.wolfram.com/groups/-/m/t/1321057 This is a cautionary tale for those who choose Mathematica as the main tool for their work. It is now clear to me that Wolfram has simply abandoned the [Graphs and Networks](http://reference.wolfram.com/language/guide/GraphsAndNetworks.html) functionality area and I am left high and dry. I have no recourse because Mathematica is closed source so there is only so much a user can do to fix or work around problems. Reporting bugs in this particular area has now clearly proven to be useless. Most simply do not get fixed, no matter how serious they are, or how great a hindrance they are to practical use. No new functionality has been added since version 10.0. My colleagues who use other tools (mostly Python and R packages) are more productive at this point, but I have a handicap with those systems because I made the mistake of investing most of my time into Mathematica, and stayed optimistic about it even in the face of the most obvious warning signs. I am writing this post because those people who have not heavily invested in Mathematica, and in particular this functionality area of Mathematica, are not in a position to see this and may fall in the same trap I did. What if the same thing happens to the functionality area that is critical to *your* work? Wolfram Research, of course, will not tell you that they gave up on `Graph`. Thus, after my experience, I think I owe it to the community to warn you about the situation. ---- Some might ask me what specifically is wrong. I have made many posts on this forum about `Graph`-bugs (you only have to search), and I reported many more to WRI. There is always a last straw—it would be pointless to show it. Those who know me will know that I am not writing this admittedly emotional post out of ill will towards WRI. I have betted on Mathematica more than most, and have been advocating for it throughout the years. I even have a network analysis package with ~250 functions. If I am forced to abandon Mathematica for this type of work, then the countless hours that went into this package will all have been in vain. I admit that I am writing this public post partly out of desperation to try to get WRI to either fix the many serious `Graph`-problems, or otherwise publicly state that `Graph` is now abandoned so those of us who have been using it can stop wasting our time. Szabolcs Horvát 2018-04-16T09:54:42Z https://community.wolfram.com/groups/-/m/t/1264240 As part of my Numberphile series of posts: - [\[Numberphile\] - Frog Jumping - Solving the puzzle][1] - [\[Numberphile\] - The Illumination Problem][2] - [\[Numberphile\] - Sandpiles - Done in the Wolfram Language][3] here is another one about a recent video called [The Square-Sum Problem][4] [![enter image description here][5]][6] The question is: if you have the integers 1 through n, can you arrange that list in such a way that every two adjacent ones sum to a square number. As seen in the video and the [extra footage][7]. We can easily check this in the Wolfram Language: Let's see which number can pair up to a pair: SquareEdges[n_Integer?Positive]:=Reap[Do[If[IntegerQ[Sqrt[i+j]],Sow[{i,j}]],{i,n-1},{j,i+1,n}]][[2,1]] Now let's try for 15, as in the main video: n = 15; poss = SquareEdges[n]; gr = Graph[TwoWayRule @@@ poss, VertexLabels -> Automatic]; path = FindHamiltonianPath[gr, PerformanceGoal :> "Speed"] HighlightGraph[gr, BlockMap[Rule @@ # &, path, 2, 1]] giving: {9, 7, 2, 14, 11, 5, 4, 12, 13, 3, 6, 10, 15, 1, 8} ![enter image description here][8] In the extra footage, it is revealed that they found the solution for up to n=299. Can we do better? Yes we can! Changing n to 300 in the above code and rerunning gives us the solution in 0.28 sec on my laptop. {289,35,65,259,30,294,67,257,32,292,69,100,44,125,71,154,135,189,211,113,248,8,281,119,205,195,166,158,283,6,250,191,133,156,285,4,252,277,12,244,117,207,193,168,273,16,240,160,164,236,20,269,131,94,230,59,197,92,232,57,199,90,234,22,267,217,224,137,152,73,123,46,150,75,121,48,148,77,179,110,214,270,19,237,163,161,239,17,272,128,41,103,297,27,262,62,227,97,99,190,210,114,175,50,146,79,177,112,212,188,253,3,286,155,134,266,23,233,91,198,58,231,93,196,60,229,95,130,159,165,276,13,243,118,206,194,167,274,15,241,288,1,255,186,138,223,218,143,181,108,88,201,55,170,86,203,53,172,84,37,107,182,142,299,25,264,220,221,140,184,216,225,64,36,85,171,54,202,87,169,56,200,89,235,21,268,132,157,284,5,251,278,11,245,116,208,192,249,7,282,247,9,280,204,120,136,153,72,124,45,151,74,122,47,149,76,180,109,215,185,139,222,219,265,24,300,141,183,106,38,83,173,52,144,81,40,104,296,28,261,63,226,98,127,42,102,298,26,263,61,228,96,129,271,18,238,162,279,10,246,115,209,275,14,242,287,2,254,187,213,111,178,78,147,49,176,80,145,51,174,82,39,105,295,29,260,101,43,126,70,291,33,256,68,293,31,258,66,34,290} and a completely mess of a graph: ![enter image description here][9] Can we go beyond? Let's optimize a code a bit, and let's find the solution for larger n: Let's store our intermediate results in the association **db**: SetDirectory[NotebookDirectory[]]; $HistoryLength=1; db=If[FileExistsQ["squaresumdb.mx"], Import["squaresumdb.mx"] , <||> ]; And now our main code: ClearAll[SquareEdges,SquareEdges2,CheckSol,TryToFind] SquareEdges[n_Integer?Positive]:=Reap[Do[If[IntegerQ[Sqrt[i+j]],Sow[{i,j}]],{i,n-1},{j,i+1,n}]][[2,1]] SquareEdges2[n_Integer]:=Module[{tmp}, tmp=Table[ {i,#}&/@(Range[Ceiling[Sqrt[2 i]],Floor[Sqrt[i+n]]]^2-i) , {i,1,n-1} ]; tmp=Join@@tmp; Select[tmp,Less@@#&] ] CheckSol[l_List]:=Sort[l]===Range[Length[l]]\[And](And@@BlockMap[IntegerQ@*Sqrt@*Total,l,2,1]) TryToFind[n_Integer?Positive]:=Module[{edges,out}, If[!KeyExistsQ[db,n], edges=SquareEdges2[n]; If[Union[Flatten[edges]]===Range[n], edges=TwoWayRule@@@edges; edges=RandomSample[edges]; Do[ out=TimeConstrained[FindHamiltonianPath[Graph[edges],PerformanceGoal:>"Speed"],5+i,$Failed]; If[out=!=$Failed, If[Length[out]==0, Print[Style["No solution for ",Red],n]; , status=Row[{"Found solution for ",n,":",i}]; ]; AssociateTo[db,n->out]; Break[] ]; Print["Failed ",n,":",i]; edges=RandomSample[edges]; , {i,5} ] , Print["Edges are not connected for ",n]; AssociateTo[db,n->{}] ] ] ] Let's scan the first 1000: Dynamic[status] status = ""; Do[TryToFind[k], {k, 3, 1000}] Export["squaresumdb.mx", db]; Note that if finding the Hamiltonian path takes too long I mix the edges and try again, sometimes, seemingly random, it then finds the solution quickly. I can tell you now that all of them have a solution. In fact I went up to larger numbers and found that all up to 2667 have a solution, and possibly beyond. I attached the notebook and the solutions in form of a mx file. [1]: http://community.wolfram.com/groups/-/m/t/1055504 [2]: http://community.wolfram.com/groups/-/m/t/1048489 [3]: http://community.wolfram.com/groups/-/m/t/1058615 [4]: https://www.youtube.com/watch?v=G1m7goLCJDY [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-01-11at23.36.51.png&userId=73716 [6]: https://www.youtube.com/watch?v=G1m7goLCJDY [7]: https://www.youtube.com/watch?v=7_ph5djCCnM [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-01-11at23.43.52.png&userId=73716 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-01-11at23.46.51.png&userId=73716 Sander Huisman 2018-01-11T23:29:05Z https://community.wolfram.com/groups/-/m/t/1007290 *NOTE: click on images to see high resolution* ---------- [![enter image description here][1]][2] What is common between a symphony and a novel? They both progress linearly in time. This is why songs match lyrics and music so well. This seems obvious but comprehension of spacial objects is different. You can look at a two-dimensional painting and your sense of art is driven by the simultaneous perception of different spacial regions and their properties: color, contrast, etc. The simultaneous comparison of many different parts is the very mechanism of spacial perception. In contrast an average person cannot read more than one sentence at a time. And listening to the same parts of melody simultaneously can create cacophony or at least shift from the intended by creator sound. Because our consciousness is forced to constantly move though time and not space, we perceive spacial and temporal structures differently. We use memory to improve comprehension of temporal phenomena. But it is till quite hard to remember and compare many different moments simultaneously. Remembering the secondary sense of "relations" or "correlations" between different moments is even harder. What if we could extract important information from a temporal structure and reflect it via a spacial visual representation? As an example let's take US presidents inaugural addresses. They are short pieces of text that at times may seem very similar to each other. So there there are 2 levels of comparison: 1. What are ideas and relations between them in a single speech? 2. What is common and different between different speeches? It is possible to create some very simple tools of text processing that give some immediate insight. In the image above you see a take on Obama 2013 and Trump 2017 inauguration speeches. Top idea-networks reflect the top ideas and relationships between them inside a speech. The top-terms are also clustered to indicate which ideas are in the tighter relationships. And word clouds show common and unique top words for each presidential address. Also notice, that while the common words are "common" they have different weights for each address, which redistributes the meaningful stress between common ideas. The Wolfram Language code for building these objects is below. It works in a very simple way. For word clouds you find unique and common words and then find their statistical weights. For the idea networks it is just a little bit more subtle. First you find "top terms" by deleting stop words and tallying the rest. Than you say that only tally weighting greater than a specific threshold counts as a "main idea" on which you build your network. The edges are drown between top-terms that are direct neighbors in the text. Thresholding of tally could be a bit misleading as selection of this cutoff is subjective and per-candidate specific. This means that a threshold chosen for one candidate may not work as well for the other because they may generate different statistical distribution of top-terms in the speeches. For Obama and Trump in the image above I used slightly different thresholds to get nicer visualizations. As a counterexample, below are net-ideas of inaugural addresses for the rest of 56 US presidents thresholded at the same **"Obama-level"**. As you can see sometimes the nets are overloaded and sometimes they are too simple. Which in itself tells something about different structures of texts and prompt us for careful treatment of the threshold. The final code and more details are given below. [![enter image description here][3]][3] A unique feature of Wolfram Language a multitudes of built-in curated data. We can access all inauguration speeches as allOBJ = SortBy[ResourceData["Presidential Inaugural Addresses"], "Date"]; This is a sample of the dataset: Column[allOBJ /@ {1, -1}] ![enter image description here][4] Extract all texts and names and dates: allTEXT = Normal[allOBJ[All, "Text"]]; allNAME = Normal[allOBJ[All, DateString[#Date, "Year"] <> " " <> CommonName[#Name] &]]; # Idea-network Idea-nets are built ideaNET[text_String,order_]:= Module[ {wordsTOP, edges,resctal, words=TextWords[DeleteStopwords[ToLowerCase[text]]]}, resctal=Transpose[MapAt[N[Rescale[#]]&,Transpose[Tally[words]],2]]; wordsTOP=Select[resctal,Last[#]>=order &]; edges=UndirectedEdge@@@DeleteDuplicates[Sort/@DeleteCases[ Partition[Cases[words,Alternatives@@wordsTOP[[All,1]]],2,1],{x_String,x_String}]]; CommunityGraphPlot[ Graph[edges, VertexSize->Thread[wordsTOP[[All,1]]->.1+.9wordsTOP[[All,2]]], VertexLabels->Automatic,VertexLabelStyle->Directive[20,White,Opacity[.8]], GraphStyle->"Prototype",Background->Black], CommunityBoundaryStyle->Directive[GrayLevel[.4],Dashed], CommunityRegionStyle->GrayLevel[.2], ImageSize->800{1,1}, PlotRangePadding->{{.1,.3},{0.1,0.1}}] ] ## Example: JFK inaugural address: ideaNET[allTEXT[[-15]], .17] [![enter image description here][5]][5] # Unique and common top-terms The code that makes very top graphics is: plusCLOUD[allTEXT[[-2]], allTEXT[[-1]], "o b a m a '13", "t ru m p '17"] With idea-nets defined as above and `plusCLOUD` as below: plusCLOUD[text1_String,text2_String,label1_String,label2_String]:= Module[ {same, words1=TextWords[DeleteStopwords[ToLowerCase[text1]]], words2=TextWords[DeleteStopwords[ToLowerCase[text2]]]}, same=Intersection[words1,words2]; Grid[ {{"",Column[{ Style[label1,80,Blue,FontFamily->"Phosphate"], Style["inaugural address",45,Gray,FontFamily->"Copperplate"] },Alignment->Center], Column[{ Style[label2,80,Red,FontFamily->"Phosphate"], Style["inaugural address",45,Gray,FontFamily->"Copperplate"] },Alignment->Center]}, {Framed[Column[Style[#,35,FontFamily->"DIN Condensed"]&/@Characters["idea network"], Alignment->Center],FrameStyle->White,FrameMargins->10], ideaNET[text1,.21],ideaNET[text2,.18]}, {Framed[Column[Style[#,35,FontFamily->"DIN Condensed"]&/@Characters["unique words"], Alignment->Center],FrameStyle->White,FrameMargins->10], WordCloud[DeleteCases[words1,Alternatives@@same],ImageSize->800{1,1}, ColorFunction->(ColorData["DeepSeaColors"][(.2+#)/1.2]&),Background->Black], WordCloud[DeleteCases[words2,Alternatives@@same],ImageSize->800{1,1}, ColorFunction->(ColorData["ValentineTones"][(.2+#)/1.2]&),Background->Black]}, {Framed[Column[Style[#,35,FontFamily->"DIN Condensed"]&/@Characters["common words"],Alignment->Center],FrameStyle->White,FrameMargins->10], WordCloud[Cases[words1,Alternatives@@same],ImageSize->800{1,1}, ColorFunction->(ColorData["AvocadoColors"][(.2+#)/1.2]&),Background->Black], WordCloud[Cases[words2,Alternatives@@same],ImageSize->800{1,1}, ColorFunction->(ColorData["AvocadoColors"][(.2+#)/1.2]&),Background->Black] }}, Spacings->{0, 0}] ] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trump.png&userId=11733 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trump.png&userId=11733 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=qwe434tgwrefv.png&userId=11733 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-02-03at8.09.19AM.png&userId=11733 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=JFKiadss.png&userId=11733 Vitaliy Kaurov 2017-02-03T14:29:00Z https://community.wolfram.com/groups/-/m/t/227651 Take a word and find its synonyms. Then find the synonyms of the synonyms from the previous step. And so on. [b]For how long will the number of synonyms continue to grow?[/b] Language structures can take peculiar shapes. Code can be quite simple to compute and automate informative visualizations. Below vertex size is larger if the vertex has more connections, meaning a word has a greater number of synonyms. Note GraphLayout -> {"BalloonEmbedding", "RootVertex" -> word} option to Graph is used to produce this specific layout. The code below is based on [url=http://wolfram.com/xid/0j49p2ci-ckbtad]an example from Documentation[/url]. Let’s define a function:[mcode]SynonymNetwork[word_String, depth_Integer, labels_: Tooltip] := Module[{ed, sz, g}, (* list of edges *) ed = Union[Sort /@ Flatten[Rest[NestList[Union[Flatten[ Thread[# <-> WordData[#, "Synonyms", "List"]] & /@ #[[All, 2]]]] &, {"" <-> word}, depth]]]]; (* size of vertices based on number of synonyms *) sz = Thread[VertexList[Graph[ed]] -> Map[{"Scaled", #} &, .05 (.01 + .99 N[Rescale[VertexDegree[g = Graph[ed]]]])^.5]]; (* graph *) SetProperty[g, {GraphLayout -> {"BalloonEmbedding", "RootVertex" -> word}, EdgeStyle -> Directive[Opacity[.2], Red], VertexStyle -> Directive[Opacity[.1], Black], VertexStyle -> {word -> Directive[Opacity[1], Red]}, VertexSize -> sz, VertexLabels -> Placed["Name", labels]}] ][/mcode] Here how it works:[mcode]SynonymNetwork["promise", 3][/mcode] [img=width: 479px; height: 727px;]/c/portal/getImageAttachment?filename=qw23rf5tef5gtbj7uyjthd.gif&userId=11733[/img] Now as I asked earlier: will the number of synonyms continue to grow? This of course depends on a particular thesaurus dictionary at hand. But once we settled on one, what can we find? Obviously some very specific words have no synonyms at all: [mcode]In[1]:= WordData["transmogrification", "Definitions"] Out[1]= {{"transmogrification", "Noun"} -> "the act of changing into a different form or appearance (especially a fantastic or grotesque one)"} In[2]:= WordData["transmogrification", "Synonyms"] Out[2]= {{"transmogrification", "Noun"} -> {}}[/mcode] Some words will have very trivial small finite networks (note network depth is set 20, while even 100 or greater will not change it):[mcode]SynonymNetwork["chemistry", 20, Above][/mcode] [img=width: 327px; height: 356px;]/c/portal/getImageAttachment?filename=sdf34erfdd43ergf.png&userId=11733[/img] And of course many words will have networks that grow very fast. This applies not only for very general words such as “fast” or “beautiful”, but also for strange rare words such as "discombobulate":[mcode]ParallelMap[Length[EdgeList[SynonymNetwork["discombobulate", #]]] &, Range[16]] Out[]= {9, 97, 1097, 7644, 26051, 46671, 59440, 65187, 67805, 68798, 69274, 69456, 69565, 69587, 69592, 69592} data = ParallelMap[Length[VertexList[SynonymNetwork["discombobulate", #]]] &, Range[16] {10, 73, 787, 4293, 11646, 18858, 22931, 24911, 25743, 26096, 26238, 26302, 26321, 26330, 26330, 26330} ListPlot[data, Filling -> Bottom, Joined -> True, Mesh -> All, AxesLabel -> {"Network depth", "Synonyms"}][/mcode] [img=width: 450px; height: 244px;]/c/portal/getImageAttachment?filename=ScreenShot2014-03-31at1.44.27AM.png&userId=11733[/img] So we see [b]"discombobulate" synonym network gets saturated at depth 15 and attains 26330 vertices and 69592 edges[/b]. Quite magnificent result I think ;-) This is, btw, very inefficient way of computing the convergence – we repeat same computations many times while building the graph. Ideally we should introduce counting synonyms part into our SynonymNetwork function. This is how “discombobulate” network looks "big" already at depth 3: [mcode]SynonymNetwork["discombobulate", 3] [/mcode][img]/c/portal/getImageAttachment?filename=df45t6576rteyrsgdfaaasdf.png&userId=11733[/img] How big do such networks get? Can we make some estimates? Well, lets first define set of all words that to belong to “discombobulate” network:[mcode]gr = SynonymNetwork["discombobulate", 15]; ver = VertexList[gr];[/mcode] Then lets find all unique words in “Alice in Wonderland”:[mcode]alice = Union[ToLowerCase[StringSplit[ExampleData[{"Text", "AliceInWonderland"}], RegularExpression["[\\W_]+"]]]]; alice // Length Out[]= 1484[/mcode] Then select, say, only nouns that have synonyms [mcode]nouns = Select[alice, MemberQ[WordData[#, "PartsOfSpeech"], "Noun"] && WordData[#, "Synonyms", "List"] =!= {} &]; nouns // Length Out[]= 809[/mcode] We see that more than half of these nouns belong to the “discombobulate” network: [mcode]MemberQ[ver, #] & /@ nouns // Tally Out[]= {{False, 223}, {True, 586}}[/mcode] I also would like to share some beautiful smaller CONVERGED (saturated) networks, which I found, - beautiful in structure and sets of words they gather (see below). They of course do not belong to huge "discombobulate" graph above. And as already mentioned I propose the following - comment if: [list] [*]you find some beautiful networks [*]you can figure out how we can make estimates on “large” networks or do any further digging  [*]you can optimize code [*]you have any ideas / comments at all ;-) [/list] [b]===> "dragonfly" - 23 synonyms, depth 3[/b] [mcode]ParallelMap[Length[VertexList[SynonymNetwork["dragonfly", #]]] &, Range[7]] Out[]= {8, 14, 23, 23} SynonymNetwork["dragonfly", 20, Above][/mcode] [img]/c/portal/getImageAttachment?filename=sdf43sfs7s683sdfs8239sf.png&userId=11733[/img] [b]===> "benevolent" - 27 synonyms, depth 7[/b] [mcode]ParallelMap[Length[VertexList[SynonymNetwork["benevolent", #]]] &, Range[9]] Out[]= {11, 15, 19, 23, 25, 26, 27, 27} SynonymNetwork["benevolent", 20, Below][/mcode] [img]/c/portal/getImageAttachment?filename=GMLO35FVFVFDffdfdzg.png&userId=11733[/img] Vitaliy Kaurov 2014-03-30T05:26:37Z https://community.wolfram.com/groups/-/m/t/1793319 ![enter image description here][1] Factorio is a game where you crashed on a planet with your space-craft. You have to built a new rocket and leave this planet again. In order to do so you will need to mine metals and built yourself a factory, make labs to do research, and built machine that make other machines, and finally combine all of this to make rockets, satellites, rocket fuel, trains, flying robots, oil products, steam engines, plastics, electronic chips, iron, copper, uranium centrifuging, solar panels etc etc. An incredibly complicated game where the key idea is that you automate this entire process using machines in your factory. See https://www.youtube.com/watch?v=KVvXv1Z6EY8 . To do research you need to manufacture research-packs which are created from other resources, which might also be created from other resources etc. etc. Here is some code that interprets the Factorio wiki: baseurl = "https://wiki.factorio.com"; ClearAll[GetImage] ClearAll[FindDependencies] GetImage[url_] := GetImage[url] = Import[url] FindDependencies[url_String] := FindDependencies[url] = Module[{xml, c, end, other, sel = 1}, xml = Import[url, "XMLObject"]; c = Cases[xml, XMLElement["table", {}, {contents_}] :> contents, \[Infinity]]; c = Select[c, MemberQ[#, XMLElement["p", {}, {"Recipe\n"}], \[Infinity]] &]; c = FirstCase[#, XMLElement[ "tr", {}, {XMLElement[ "td", {___, "class" -> "infobox-vrow-value"}, {x__}]}] :> {x}, Missing[], \[Infinity]] & /@ c; If[Length[c] > 0, c = c[[sel]]; c = Cases[c, XMLElement[ "div", {"class" -> "factorio-icon", "style" -> "background-color:#999;"}, {XMLElement[ "a", {"shape" -> "rect", "href" -> hrefurl_, "title" -> name_}, {XMLElement[ "img", {"alt" -> _, "src" -> imgurl_, "width" -> "32", "height" -> "32",___}, {}]}], XMLElement[ "div", {"class" -> "factorio-icon-text"}, {num_}]}] :> FactorioObject[baseurl <> hrefurl, name, GetImage[baseurl <> imgurl], ToExpression@StringTrim[StringReplace[num, "k" -> "000"]]], \[Infinity]]; c = DeleteCases[c, FactorioObject[_, "Time", _, _]]; {{end}, other} = TakeDrop[c, -1]; other -> end, {} ] ] ClearAll[FindDependencyTree] FindDependencyTree[url_String, iterations_: 6] := Module[{a, known, unknown, new, vlbls, vertices}, a = FindDependencies[url]; known = {a}; Do[ unknown = Join @@ known[[All, 1]]; unknown = DeleteDuplicates[Complement[unknown, known[[All, 2]]]]; new = DeleteDuplicates[FindDependencies@*First /@ unknown]; new = DeleteCases[new, {}]; known = DeleteDuplicates[Join[known, new]]; , {iterations} ]; vlbls = Cases[known, FactorioObject[_, name_, icon_, _] :> (name -> Image[icon, ImageSize -> 32]), \[Infinity]]; vertices = DeleteDuplicates[ Join @@ Table[(# -> k[[2, 2]]) & /@ k[[1, All, 2]], {k, known}]]; <|"LabelRules" -> vlbls, "Vertices" -> vertices, "Dependencies" -> known|> ] Let's ask the dependency tree for the first science pack: out1 = FindDependencyTree["https://wiki.factorio.com/Science_pack_1"]; Graph[out1["Vertices"], VertexShape -> out1["LabelRules"], VertexSize -> {"Scaled", 0.05}] ![enter image description here][2] To make Science pack 1, we need gears and copper plates. And to make gears we need iron plates. The iron and copper plates are made from iron and copper ore. This is still relatively simple, let's look at the other science packs: out2 = FindDependencyTree[ "https://wiki.factorio.com/Science_pack_2"]; Graph[out2["Vertices"], VertexShape -> out2["LabelRules"], VertexSize -> {"Scaled", 0.05}] out3 = FindDependencyTree[ "https://wiki.factorio.com/Science_pack_3"]; Graph[out3["Vertices"], VertexShape -> out3["LabelRules"], VertexSize -> {"Scaled", 0.05}] out4 = FindDependencyTree[ "https://wiki.factorio.com/Military_science_pack"]; Graph[out4["Vertices"], VertexShape -> out4["LabelRules"], VertexSize -> {"Scaled", 0.05}] out5 = FindDependencyTree[ "https://wiki.factorio.com/Production_science_pack"]; Graph[out5["Vertices"], VertexShape -> out5["LabelRules"], VertexSize -> {"Scaled", 0.05}] out6 = FindDependencyTree[ "https://wiki.factorio.com/High_tech_science_pack"]; Graph[out6["Vertices"], VertexShape -> out6["LabelRules"], VertexSize -> {"Scaled", 0.05}] Resulting in: ![enter image description here][3] ![enter image description here][4] ![enter image description here][5] ![enter image description here][6] ![enter image description here][7] To summarize, let's combine all the graphs: o = {out1, out2, out3, out4, out5, out6}; Graph[Union @@ o[[All, "Vertices"]], VertexShape -> Union @@ o[[All, "LabelRules"]], VertexSize -> {"Scaled", 0.02}, ImageSize -> 1000, AspectRatio -> 1/GoldenRatio] ![enter image description here][8] As you can see the dependencies are very complex to get all the research packs. Of course there are many things you need to create with your machines, think of transport belts, trains, mining, steam generation, and energy production, water and other chemicals etc etc. One of the most expensive parts is a satellite (to guide your rocket): out = FindDependencyTree["https://wiki.factorio.com/Satellite"]; Graph[out["Vertices"], VertexShape -> out["LabelRules"], VertexSize -> {"Scaled", 0.05}] ![enter image description here][9] I hope you like this little exploration on Graphs and Factorio. We could also use Mathematica's Graph technology to design balanced belt splitter designs: http://i.imgur.com/tz2Jc3p.png ! I will leave that for some other time. For now, explore the different buildings or parts, for example have a look at the rocket silo: out = FindDependencyTree["https://wiki.factorio.com/Rocket_silo"]; Graph[out["Vertices"], VertexShape -> out["LabelRules"], VertexSize -> {"Scaled", 0.05}] If you haven't played already… be careful… it is an incredibly addicting game! [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=fd1f632099404d13bb4a9c2ce3f1284e92058e00078b28baf5e6858887e5c505_product_card_v2_mobile_slider_639.jpg&userId=73716 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2381Factorio_1.png&userId=73716 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Factorio_2.png&userId=73716 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Factorio_3.png&userId=73716 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Factorio_4.png&userId=73716 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Factorio_5.png&userId=73716 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Factorio_6.png&userId=73716 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Factorio_All.png&userId=73716 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Factorio_Satellite.png&userId=73716 Sander Huisman 2019-09-20T16:56:46Z https://community.wolfram.com/groups/-/m/t/151105 I have a table that I imported from a csv file with 15 columns of hippocampal subregion volumes and some memory tests. For some reason, mathematica does not make it easy to make a simple x vs. y plot. Any Ideas how I could simply refer to two colums that I want plotted against each other? Extra: I would really like to use headers in the csv, but I had to take them out because mathematica cannot handle them without what seems like a lot of extra work. Any advice? I should probably just go back to r.... Thank you all in advance for any help! trodriguez2011 2013-11-09T05:36:23Z https://community.wolfram.com/groups/-/m/t/497445 Today I watched this TED talk "[Why city flags may be the worst-designed thing you've never noticed][1]" and it made me really curious about how the five basic principles of flag design apply to countries. Certainly, most country flags are so simple that a child can draw them from memory. But this principle increases the odds of having flag duplicates, and to show this I've written the following WL code: countries = CountryData["Countries", "Name"]; flags = Rasterize /@ CountryData["Countries", "Flag"]; similarities = # -> First[Nearest[DeleteCases[flags, #], #]] & /@ flags; g = Graph[Labeled[#[[2]],Placed[Tooltip[#[[2]],#[[1]]],{.7,.6}]]&/@Transpose[{countries,flags}],similarities,ImageSize->3500] ![Flags of all countries group by similarity][2] ImageCollage[Length[#] -> ImageCollage[#] & /@ WeaklyConnectedComponents[g]] ![Flags Collage by Similarity][3] GraphicsGrid[Partition[Flatten[WeaklyConnectedComponents[g]], 6], Background -> Gray] ![List of similar flags][4] Feel free to explore the similarity graph of flags in the CDF attached below. ![Flag Similarity Graph][6] Are these similarities mere accidents or deliberate flag copies? Mapping the countries with similar flags might answer this question. To get started, here is how to [Map the Countries of Africa with Their Flags][5]. [1]: https://www.ted.com/talks/roman_mars_why_city_flags_may_be_the_worst_designed_thing_you_ve_never_noticed [2]: /c/portal/getImageAttachment?filename=SimilarityCountryFlagsGraph.png&userId=56204 [3]: /c/portal/getImageAttachment?filename=SimilarityCountryFlagsCollage.png&userId=56204 [4]: /c/portal/getImageAttachment?filename=SimilarityFlagsGrid.png&userId=56204 [5]: http://www.wolfram.com/mathematica/new-in-10/entity-based-geocomputation/map-the-countries-of-africa-with-their-flags.html [6]: /c/portal/getImageAttachment?filename=FlagGraph.gif&userId=56204 Bernat Espigulé 2015-05-15T20:25:24Z https://community.wolfram.com/groups/-/m/t/33771 From a recent Complex System article [1] I found out about interesting mapping between Graphs and Time Series that currently gaining more and more attention. The main idea is being able to apply time series analysis methods to networks and vice versa. There is a hope of gaining new insights into familiar objects by approaching from different side. I thought it would be interesting to implement a toy example in Mathematica. I consider the simplest Horizontal Visibility Graph (HVG) algorithm which can be simply explained with the figure below. [img]http://i.imgur.com/uK2jT.png[/img]    1. Every event in time series correspond to a vertex in the graph    2. Two events are connected by edge in the graph if all events between them in time series a smaller then them in magnitude There are other more complex mapping algorithms (see references at the end), but we’ll stick with this simple one. Let’s consider three different types of time series to see what kind of networks they can produce:    1. Deterministic system: Cellular Automaton rule 54 with complex type 4 behavior    2. Stochastic system: Geometric Brownian Motion random process    3. Empirical system: Financial data of GE stock price [mcode]dataS = {FromDigits[#, 2] & /@ CellularAutomaton[54, RandomInteger[1, 200], 49], RandomFunction[GeometricBrownianMotionProcess[0, .1, 2], {1, 50, 1}][[2, 1, 1]], FinancialData["GE", "Jan. 1, 2000"][[All, 2]][[1 ;; 50]]}; ListPlot[#, Filling -> Bottom, AspectRatio -> 1/10, FillingStyle -> Thick, PlotStyle -> PointSize[.008], Axes -> {True, False}, GridLines -> {None, Automatic}, Ticks -> {Range[81], None}, ImageSize -> 800] & /@ dataS [/mcode] [img]http://i.imgur.com/aI72Q.png[/img] Define the mapping function [mcode]fied[m_, n_, data_] := If[(Min[#[[m]], #[[n]]] > Max[#[[m + 1 ;; n - 1]]]) &@data, m \[UndirectedEdge] n][/mcode]Compute the edges of the graph [mcode]edgesS = Cases[Flatten[Table[fied[m, n, #], {m, Length[#]}, {n, m + 1, Length[#]}]], _ \[UndirectedEdge] _] & /@ dataS;[/mcode]Build the graph and highlight vertexes based on vertex degree and the shortest path between initial and final events. [mcode]gS = Graph[#, GraphLayout -> "LayeredDigraphEmbedding"] & /@ edgesS; gSH = HighlightGraph[#, VertexList[#], VertexSize -> Thread[VertexList[#] -> Rescale[VertexDegree[#]]], ImageSize -> {Automatic, 500}, VertexLabels -> "Name"] & /@ gS; HighlightGraph[#, PathGraph[FindShortestPath[#, 1, 50]], GraphHighlightStyle -> "Thick"] & /@ gSH[/mcode][img]http://i.imgur.com/2bQU6.png[/img] I used LayeredDigraphEmbedding which kind of preserves chronological order of the series laying out networks nicely. I hope you enjoyed this little mapping and may apply a similar method for your own research. There are inverse mappings too - see the reference. Please feel free to share your ideas on the subject or possible algorithm optimization.    [1] [b][url=http://www.complex-systems.com/abstracts/v21_i03_a03.html]Discriminating Chaotic Visibility Graph Eigenvalues, Vincenzo Fioriti et al, Complex Systems, Vol 21, No 3, p193[/url][/b]    [2] [b][url=http://www.pnas.org/content/105/13/4972.full]From time series to complex networks: The visibility graph[/url][/b]    [3] [b][url=http://www.ncbi.nlm.nih.gov/pmc/articles/PMC3154932/pdf/pone.0023378.pdf]Duality between Time Series and Networks[/url][/b]    [4] [b][url=http://arxiv.org/find/all/1/AND+abs:+AND+visibility+graph+abs:+AND+time+series/0/1/0/all/0/1?skip=0&query_id=701ef182d80b670f]Some related arXiv.org papers[/url][/b] Vitaliy Kaurov 2013-01-17T03:13:27Z https://community.wolfram.com/groups/-/m/t/1112012 [Shadow mapping][1] is a process of applying shadows to a computer graphic. `Graphics3D` allows the user to specify lighting conditions for the surfaces of 3D graphical primitives, however, visualising the shadow an object projects onto a surface requires the processes of shadow mapping. Each pixel of the projection surface must check if it is visible from the light source; if this check returns false then the pixel forms a shadow. This becomes a problem of geometric intersections, i.e., for this case, the intersection between a line and a triangle. For a 3D model with 100s and more of polygons, repeated intersection tests across the entire model for each pixel is an extremely costly (and inefficient) task. Now this becomes a problem of search optimisation. ![enter image description here][2] Obtaining Data -------------- This project uses 3D models from [SketchUp's online repository][3] which are converted to COLLADA files using SketchUp. The functions used are held in a package, accessible via [github][4] along with all the data referenced throughout. (* load package and 3D model *) << "https://raw.githubusercontent.com/b-goodman/\ GeometricIntersections3D/master/GeometricIntersections3D.wl"; modelPath = "https://raw.githubusercontent.com/b-goodman/\ GeometricIntersections3D/master/Demo/House/houseModel4.dae"; (* vertices of model's polygons *) polyPoints = Delete[0]@Import[modelPath, "PolygonObjects"]; (* import model as region *) modelRegion = Import[modelPath, "MeshRegion"]; (* use region to generate minimal bounding volume *) cuboidPartition = Delete[0]@BoundingRegion[modelRegion, "MinCuboid"]; (* verify *) Graphics3D[{ Polygon[polyPoints], {Hue[0, 0, 0, 0], EdgeForm[Black], Cuboid[cuboidPartition]} }, Boxed -> False] ![imported model data][5] Generate a Bounding Volume Hierarchy (BVH) ------------------------------------------ Shadow mapping (and more generally collision testing) may be optimised via space partitioning achieved by dividing the 3D model's space into a hierarchy of bounding volumes (BV) stored as a graph, thus forming a [bounding volume hierarchy][6]. The simplest case uses the result of an intersection between a ray and a single BV for the entire model to discard all rays which don't come close to any of the model's polygons. Of course, those which do pass the first test must still be tested against the entire model so the initial BV is subdivided with each sub BV assigned to a particular part of the model hence reducing the total amount of polygons to be tested against. The initial BV forms the root of the tree and it's subdivisions (leaf boxes) are joined via edges. We can add more levels to the tree by repeating the subdivision for each of the leaf boxes and ultimately refining the search for potential intersecting polygons. (* Begin tree. Initial AABB is root. Subdivide root AABB and link returns to root *) newBVH[cuboidPartitions_,polyPoints_]:=Block[{ newLevel,edges }, newLevel=Quiet[cullIntersectingPartitions[cuboidSubdivide[cuboidPartitions],polyPoints]]; edges=cuboidPartitions\[DirectedEdge]#&/@newLevel; Return[<| "Tree"->TreeGraph[edges], "PolygonObjects"->polyPoints |>]; ]; bvh = newBVH[{cuboidPartition}, polyPoints]; The BVH is a tree graph with the model's polygon vertices encapsulated within an association Keys[bvh] {"Tree", "PolygonObjects"} The BVH consists of a root box derived from the model's minimal bounding volume and it's 8 sub-divisions bvh["Tree"] ![enter image description here][7] The boxes at the lowest level of the BVH are the leaf boxes leafBoxesLV1 = Select[VertexList[bvh["Tree"]], VertexOutDegree[bvh["Tree"], #] == 0 &]; Graphics3D[{ Polygon[polyPoints], {Hue[0, 0, 0, 0], EdgeForm[Black], Cuboid /@ leafBoxesLV1} }, Boxed -> False] ![enter image description here][8] Adding a new level sub-divides each leaf box into 8 sub-divisions. With[{ testCuboid = {{0, 0, 0}, {10, 10, 10}} }, Manipulate[ Graphics3D[{ If[n == 0, Cuboid[testCuboid], Cuboid /@ Nest[cuboidSubdivide, testCuboid, n]] }, Boxed -> False, Axes -> {True, False}], {{n, 0}, 0, 4, 1} ] ] ![enter image description here][9] The time needed for each addition to the BVH increases dramatically. Length /@ NestList[cuboidSubdivide, {{{0, 0, 0}, {1, 1, 1}}}, 5] {1, 8, 64, 512, 4096, 32768} 1-2 added levels is usually enough for the models used in this project. (* Each new subdivision acts as root. For each, subdivide further and remove any non-intersecting boxes. Link back to parent box as directed edge *) addLevelBVH[BVH_]:=Block[{ tree=BVH["Tree"],polyPoints=BVH["PolygonObjects"],returnEdges }, Module[{ subEdges=Map[ Function[{levelComponent},levelComponent\[DirectedEdge]#&/@Quiet@cullIntersectingPartitions[cuboidSubdivide[levelComponent],polyPoints]], Pick[VertexList[tree],VertexOutDegree[tree],0]] }, returnEdges=ConstantArray[0,Length[subEdges]]; Do[returnEdges[[i]]=EdgeAdd[tree,subEdges[[i]]],{i,1,Length[subEdges],1}]; ]; returnEdges=DeleteDuplicates[Flatten[Join[EdgeList/@returnEdges]]]; Return[<| "Tree"->TreeGraph[returnEdges], "PolygonObjects"->polyPoints |>] ]; bvh2 = addLevelBVH[bvh]; bvh2["Tree"] ![enter image description here][10] Any subs which don't intersect with the model don't contribute to the BVH and so are removed as part of the process. cullIntersectingPartitions=Compile[{ {cuboidPartitions,_Real,3}, {polyPoints,_Real,3} }, Select[cuboidPartitions,Function[{partitions},MemberQ[ParallelMap[Quiet@intersectTriangleBox[partitions,#]&,polyPoints],True]]], CompilationTarget->"C" ]; Visualising the leaf boxes shows that empty BVs are removed. leafBoxesLV2 = Select[VertexList[bvh2["Tree"]], VertexOutDegree[bvh2["Tree"], #] == 0 &]; Graphics3D[{ Polygon[polyPoints], {Hue[0, 0, 0, 0], EdgeForm[Black], Cuboid /@ leafBoxesLV2} }, Boxed -> False] ![enter image description here][11] Once all levels are added, the BVH is finalised by linking each leaf box to its associated polygons. This does not effect the tree structure as the link association is held seperate. (*For each outermost subdivision (leaf box), find intersecting polygons. Link to intersecting box via directed edge. Append to graph *) finalizeBVH[BVH_]:=Block[{ (* all leaf boxes for BVH *) leafBoxes=Select[ VertexList[BVH["Tree"]], VertexOutDegree[BVH["Tree"],#]==0& ], (* setup temp association *) temp=<||>, (* block varaibles *) leafPolygons, leafPolygonsEdges }, (* For each BVH leaf box *) Do[ (* 3.1. intersecitng polygons for specified BVH leaf box *) leafPolygons=Select[ BVH["PolygonObjects"], Quiet@intersectTriangleBox[leafBoxes[[i]],#]==True& ]; (* 3.2. associate each specified BVH leaf box to its intersecting polygon(s) *) AppendTo[temp,leafBoxes[[i]]->leafPolygons], {i,1,Length[leafBoxes],1} ]; Return[<| "Tree"->BVH["Tree"], "LeafObjects"->temp, "PolygonObjects"->BVH["PolygonObjects"] |>] ]; bvh2 = finalizeBVH[bvh2]; While it only needs doing once, generating the BVH is often the longest part of the procedure so it's a good idea to export it on completion. Generating The Scene -------------------- The scene is an encapsulation of all data and parameters used for the ray caster. It's initially structured as: scene=<| "BVH"->BVHobj, -- (*The BVH previously generated*) "SourcePositions"->lightingPath, -- (*The 3D position(s) of the light source*) "FrameCount"->frameCount, -- (*A timestep for animation and a parameter if lightingPath is continuous*) "Refinement"->rayRefinement, -- (*Ray density; smaller values give finer results.*) "ProjectionPoints"->planeSpec, -- (*3D points forming surface(s) that shadow(s) are cast onto.*) "FrameData"-><||> -- (*Initially empty, data from the ray caster will be stored here.*) |> Generating The Projection Surface ----------------------------- The house should look like its casting it's shadow onto the earth so we define a list of points which represent the discrete plane it stands on. Each ray is a line drawn between each point on the projection surface and the position of the scene's light source. (* rayRefinement *) ref = 20; (* the height of the projection surface *) planeZoffset = 0; (* the discrete projection surface - each point is the origin of a \ ray *) projectionPts = Catenate[Table[{x, y, planeZoffset}, {x, -900, 1200, ref}, {y, -600, 1000, ref}]]; Graphics3D[{ Polygon[polyPoints], Cuboid /@ ({##, ## + {ref, ref, 0}} & /@ projectionPts) }, Axes -> True, AxesLabel -> {"X", "Y", "Z"}, ImageSize -> Large] ![enter image description here][12] Specifying A Light Source ------------------------- The light source is typically a continuous BSplineFunction which is sampled according to the number of frames the user wants. But it may also be a discrete list of 3D points too (in which case the number of frames is equal to the length of the list). Using a modification of a `SunPosition` example in the documentation, a list of the 3D Cartesian positions of the sun between sunrise and sunset, with a time step 30 minutes, is produced. ![enter image description here][13] solarPositionPts0[location_:Here, date_:DateValue[Now,{"Year","Month","Day"}],tSpec_:{30,"Minute"}]:= Evaluate[CoordinateTransformData["Spherical"->"Cartesian","Mapping",{1,\[Pi]/2-(#2 Degree),2Pi-(#1 Degree)}]]&@@@(Function[{series},Map[QuantityMagnitude,series["Values"],{2}]]@SunPosition[location,DateRange[Sunrise[#],Sunset[#],tSpec]&[DateObject[date]]]) solarPositionPts[Here, DateObject[{2017, 6, 1}], {30, "Minute"}] {{0.4700, -0.88253, -0.0155}, {0.4026, -0.91178, 0.0809},...,{0.4219, 0.90493, 0.0554}} It's easier to rotate the sun's path rather than the model and projection plane. Different transforms may also be applied to best-fit the path into the scene. solarXoffset = 0; solarYoffset = 0; solarZoffset = 0; zRotation = \[Pi]/3.5; scale = 1300; sourceSpec = RotationTransform[zRotation, {0, 0, 1}][ # + {solarXoffset, solarYoffset, solarZoffset} & /@ (solarPositionPts[Here, DateObject[{2017, 6, 1}], {30, "Minute"}] scale) ]; lightingPath = BSplineCurve[sourceSpec]; Specify A Frame Count --------------------- A frame count must be specified to discretize the light path into 3D points. Each of these points forms the end of each ray. If the light source is a discrete list, then its length is used to infer the frame count instead and does not need specifying by the user. frameCount = 30; Constructing The Scene ---------------------- Now we can preview the scene Graphics3D[{ Polygon[polyPoints], Cuboid /@ ({##, ## + {ref, ref, 0}} & /@ projectionPts), lightingPath, {Darker@Yellow, PointSize[0.03], Point[BSplineFunction[sourceSpec] /@ Range[0, 1, N[1/frameCount]]]} }, Axes -> True, AxesLabel -> {"X", "Y", "Z"}, ImageSize -> Large] ![enter image description here][14] All paramaters have been set, it's time to construct the scene. Specifying a continuous lighting path must be done using a `BSPlineCurve`. scene = newScene[bvh2, lightingPath, frameCount, ref, projectionPts] ![enter image description here][15] Processing A Scene For Shadow Mapping ------------------------------------- The BVH optimises the ray caster by reducing the number of polygons to search against for an intersection. If the ray intersects with the BVH root box then a breadth-first search along the BVH tree is initiated. Starting with the root box,the out-components are selected by their intersection with a ray and are used as roots for the search's next level. (* select peripheral out-components of root box that intersect with ray *) intersectingSubBoxes[BVHObj_,initialVertex_,rayOrigin_,raySource_]:=Select[Rest[VertexOutComponent[BVHObj["Tree"],{initialVertex},1]],intersectRayBox[#,rayOrigin,raySource]==True&]; (* for root box intersecting rays, find which leaf box(es) intersect with ray *) BVHLeafBoxIntersection[BVHObj_,rayInt_,rayDest_]:=Block[{v0}, (*initialize search *)v0=intersectingSubBoxes[BVHObj,VertexList[BVHObj["Tree"]][[1]],rayInt,rayDest]; (* breadth search *) If[v0=={},Return[v0], While[ (* check that vertex isn't a polygon - true if !0. Check that intersection isn't empty *) AllTrue[VertexOutDegree[BVHObj["Tree"],#]&/@v0,#=!=0&], v0=Flatten[intersectingSubBoxes[BVHObj,#,rayInt,rayDest]&/@v0,1]; If[v0==={},Break[]] ]; Return[v0]; ] ]; The code below generates a visualisation of this process using the input data from the scene generated. raySource = scene["ProjectionPoints"][[3700]]; rayDestination = scene["FrameData"][16]["SourcePosition"]; lv1Intersection = BVHLeafBoxIntersection[bvh, raySource, rayDestination]; lv2Intersection = BVHLeafBoxIntersection[bvh2, raySource, rayDestination]; lv1Subgraph = Subgraph[Graph[EdgeList[bvh2["Tree"]]], First[VertexList[bvh2["Tree"]]] \[DirectedEdge] # & /@ lv1Intersection]; lv2Subgraphs = Subgraph[Graph[EdgeList[bvh2["Tree"]]], Flatten[Table[ lv1Intersection[[ i]] \[DirectedEdge] # & /@ (Intersection[#, lv2Intersection] & /@ ((Rest@ VertexOutComponent[bvh2["Tree"], #] & /@ lv1Intersection)))[[i]], {i, 1, Length[lv1Intersection], 1} ], 1]]; lbl = ((#[[1]] -> #[[2]]) & /@ (Transpose[{lv2Intersection, ToString /@ Range[Length[lv2Intersection]]}])); edgeStyle = Join[ ReleaseHold@ Thread[(# -> HoldForm@{Thick, Blue}) &[EdgeList[lv2Subgraphs]]], ReleaseHold@ Thread[(# -> HoldForm@{Thick, Red}) &[EdgeList[lv1Subgraph]]] ]; rayBVHTraversal = Graph[EdgeList[bvh2["Tree"]], EdgeStyle -> edgeStyle, VertexLabels -> lbl, GraphHighlight -> lv2Intersection, ImageSize -> Medium]; rayModelIntersection = Graphics3D[{ {Green, Thickness[0.01], Line[{raySource, rayDestination - {220, -400, 400}}]}, {Hue[0, 0, 0, 0], EdgeForm[{Thick, Red}], Cuboid /@ lv1Intersection}, {Hue[.6, 1, 1, .3], EdgeForm[{Thick, Blue}], Cuboid /@ lv2Intersection}, {Opacity[0.5], Polygon[polyPoints]}, Inset @@@ Transpose[{ToString /@ Range[Length[lv2Intersection]], RegionCentroid /@ Cuboid @@@ lv2Intersection}] }]; Column[{ Row[ Show[rayModelIntersection, ViewPoint -> #, Boxed -> False, ImageSize -> Medium] & /@ {{-\[Infinity], 0, 0}, {0, -\[Infinity], 0}} ], rayBVHTraversal }] ![enter image description here][17] At the centre of the graph lies the vertex representing the root BV where all searches originate from. The search continues out form all vertices which have intersected with the ray. (* test intersection between ray and object polygon via BVH search *) intersectionRayBVH[BVHObj_,rayOrigin_,rayDest_]:=With[{ intersectionLeafBoxes=BVHLeafBoxIntersection[BVHObj,rayOrigin,rayDest] }, Block[{i},If[intersectionLeafBoxes=!={}, Return[Catch[For[i=1,i<Length[#],i++, Function[{thowQ},If[thowQ,Throw[thowQ]]][intersectRayTriangle[#[[1]],#[[2]],#[[3]],rayOrigin,rayDest]&@#[[i]]] ]&[DeleteDuplicates[Flatten[Lookup[BVHObj["LeafObjects"],intersectionLeafBoxes],1]]]]===True], Return[False] ]] ]; Once the tree has been fully searched, the remaining boxes are used to lookup their associated polygons. Since the same polygon may intersect more than one box, any duplicates are deleted. A line-triangle intersection test is iteratively applied over the resultant list, breaking at the first instance of a True return. This ray has now been found to intersect a part of the 3D model thus its origin point (from the `projectionPts` list) will represent a single point of shadow on the projection surface. This point is stored in a list which will be used to draw the shadow for a single frame. candidatePolys = DeleteDuplicates[Flatten[Lookup[ bvh2["LeafObjects"], BVHLeafBoxIntersection[bvh2, raySource, rayDestination] ], 1]]; intersectingPolys = Select[candidatePolys,PrimitiveIntersectionQ3D[Line[{raySource, rayDestination}],Triangle[#]] &]; rayModelIntersectionPolys = Graphics3D[{ {Green, Thickness[0.01], Line[{raySource, rayDestination - {220, -400, 400}}]}, {Hue[1, 1, 1, .5], EdgeForm[Black], Polygon[candidatePolys]}, {Hue[0.3, 1, 1, .5], Polygon[intersectingPolys]} }, Boxed -> False]; Row[Show[rayModelIntersectionPolys, ViewPoint -> #, ImageSize -> Medium] & /@ {{0, 0, \[Infinity]}, {0, \[Infinity], 0}}] Highlighted in green, the ray has been found to intersect with 2 polygons. ![enter image description here][18] The BVH search is performed for each ray, for each frame. A scene is the input for the ray caster. If a scene is to be re-processed with different parameters then a new scene must be made. The output of the ray caster is held within a scene object. The data for each frame is associated to its frame index and is all held in the scene's "FrameData" field. Begin processing. A status bar will indicate progress in terms of frames rendered. scene = renderScene[scene]; it's best to save any progress by exporting afterwards. Export["House_scene.txt", Compress[scene]] Reviewing Processed Scenes -------------------------- Each frame holds the shadow and ground data separately and have been expressed as zero-thickness cuboids (tiles) and each with side length equal to the `rayRefinement` parameter (recall that smaller values yield finer results). Individual frames are accessed by their frame index. This examines frame 10. Keys[scene["FrameData"][10]] {"ShadowPts", "SourcePosition", "GroundPts"} Accessing the processed scene's "FrameData" field allows a single specified frame to be drawn in Graphics3D. Graphics3D[{ Polygon[scene["BVH"]["PolygonObjects"]], {GrayLevel[0.3], EdgeForm[], Cuboid /@ scene["FrameData"][10]["ShadowPts"]}, {EdgeForm[], Cuboid /@ scene["FrameData"][10]["GroundPts"]}, {Darker@Yellow, PointSize[0.04], Point[scene["FrameData"][10]["SourcePosition"]]} }, Boxed -> False, Background -> LightBlue] ![enter image description here][23] `viewSceneFrame` does the task above for any processed scene and specified frame. It inherits Graphics3D options as well as custom ones affecting the scene elements (shadow and ground style, toggle source drawing and gridlines). viewSceneFrame[scene, 10, DrawGrid -> False, ShadowColor -> GrayLevel[0.3], SurfaceColor -> Lighter@Orange, DrawSource -> True, Boxed -> False, Background -> LightBlue] ![enter image description here][24] Show[viewSceneFrame[scene, 10, DrawGrid -> False, ShadowColor -> GrayLevel[0.3], SurfaceColor -> Lighter@Orange, DrawSource -> True, Boxed -> False, Background -> LightBlue], ViewPoint -> {0, 0, \[Infinity]}] ![enter image description here][25] sceneBounds = Join[ Most[MinMax /@ Transpose[scene["ProjectionPoints"]]], {MinMax[ Last /@ Values[scene["FrameData"][[All, "SourcePosition"]]]]} ]; viewSceneFrame[scene, 10, DrawGrid -> False, ShadowColor -> GrayLevel[0.3], SurfaceColor -> Lighter@Orange, DrawSource -> True, Boxed -> False, Background -> LightBlue, Axes -> True, AxesLabel -> {"X", "Y", "Z"}, PlotRange -> sceneBounds] ![enter image description here][26] Retaining the same options, the scene may also be animated. To ensure a smooth playback, each frame is exported as .gif into `$TemporaryDirectory`, imported back as a list and animated. The animation is also exported for future use. animateScene[scene, DrawGrid -> False, ShadowColor -> GrayLevel[0.3], SurfaceColor -> Lighter@Orange, DrawSource -> True, Boxed -> False, Background -> LightBlue, PlotRange -> sceneBounds, ImageSize -> {{800}, {600}} ] ![enter image description here][27] We can also plot the cumulative solar exposure. All points from the projection plane which don't intersect with the model (i.e, aren't shadow points) are extracted from the scene's frames exposure = Values[scene["FrameData"][[All, "GroundPts"]]] ![enter image description here][28] The occurrences of each exposure point is tallied tally = Tally[Flatten[exposure, 1]] ![enter image description here][29] And the range of frequencies from which is generated tallyRange = Range @@ Insert[MinMax[Last /@ SortBy[tally, Last]], 1, -1] {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, \ 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30} A color scale corresponding to the range of frequencies from above will be used to colorize the plot colorScale = ColorData["SolarColors", "ColorFunction"] /@ Rescale[tallyRange] ![enter image description here][30] Replacement rules are used to replace each exposure point's frequency with it's corresponding color colorScaleRules = Thread @@ {tallyRange -> colorScale} ![enter image description here][31] The resultant exposure map is a list of tiles, each coloured according to it's positional frequency. heatMap = Insert[MapAt[Cuboid, Reverse@MapAt[Replace[colorScaleRules], #, -1], -1], EdgeForm[], 2] & /@ tally ![enter image description here][32] Finally, the map is drawn. It's still a `Graphics3D` object so it may be rotated and viewed from any angle. Row[{ Show[Graphics3D[{ {Opacity[0.3], Green, Polygon[scene["BVH"]["PolygonObjects"]]}, heatMap }, Boxed -> False, ImageSize -> Large], ViewPoint -> Above], BarLegend[{"SolarColors", MinMax[tallyRange]}] }] ![enter image description here][33] The process of generating an exposure map forms a function within the `GeometricIntersections3D` package. Alternative color schemes may also be specified. sceneExposureMap[scene, "TemperatureMap"] ![enter image description here][34] The bar scale for the exposure plot measures duration in frames but a time scale may be recovered. Given that the solar path used to light the scene lasts about 14 hours and the scene was rendered for 30 frames, that gives about 30 minutes per frame. dailySunHours = UnitConvert[DateDifference[Sunrise[], Sunset[]], MixedRadix["Hours", "Minutes", "Seconds"]] ![enter image description here][35] dailySunHours/30 ![enter image description here][36] This has been a very rewarding project with some exciting potentials beyond computer graphics. Indeed, much optimisations can be made to the intersections package. The different methods of space partitioning for BVH construction should be investigated as the one currently employed is rather rudimentary. Anti-aliasing methods to be investigated also. Both the House and Sundial processes are documented in the notebooks attached. All necessary data may also be downloaded to save time. [1]: https://en.wikipedia.org/wiki/Shadow_mapping [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=animation.gif&userId=605083 [3]: https://3dwarehouse.sketchup.com/ [4]: https://github.com/b-goodman/GeometricIntersections3D [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_Import.png&userId=605083 [6]: https://en.wikipedia.org/wiki/Bounding_volume_hierarchy [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_TreeLV1.png&userId=605083 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_leafBoxesLV1.png&userId=605083 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=cuboidSubdivide.gif&userId=605083 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_TreeLV2.png&userId=605083 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_leafBoxesLV2.png&userId=605083 [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_projectionPoints.png&userId=605083 [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=solarPosition.PNG&userId=605083 [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_scenePreview.png&userId=605083 [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_sceneConstructor.png&userId=605083 [16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_projectionPoints.png&userId=605083 [17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_raySearch.png&userId=605083 [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_rayIntersection.png&userId=605083 [19]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_projectionPoints.png&userId=605083 [20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_projectionPoints.png&userId=605083 [21]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_projectionPoints.png&userId=605083 [22]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_projectionPoints.png&userId=605083 [23]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_singleFrame_1.png&userId=605083 [24]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_singleFrame_2.png&userId=605083 [25]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_singleFrame_3.png&userId=605083 [26]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_singleFrame_4.png&userId=605083 [27]: http://community.wolfram.com//c/portal/getImageAttachment?filename=animation_House.gif&userId=605083 [28]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_exposureStep_A.png&userId=605083 [29]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_exposureStep_B.png&userId=605083 [30]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_exposureStep_C.png&userId=605083 [31]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_exposureStep_D.png&userId=605083 [32]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_exposureStep_E.png&userId=605083 [33]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_solarMap_A.png&userId=605083 [34]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Process_House_solarMap_B.png&userId=605083 [35]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sunHours.png&userId=605083 [36]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sunHoursPerFrame.png&userId=605083 Benjamin Goodman 2017-06-01T07:01:10Z https://community.wolfram.com/groups/-/m/t/560469 *WOLFRAM MATERIALS for the ARTICLE:* > Szabolcs Horvát, Jakub Podkalicki, Gábor Csárdi, Tamás Nepusz, Vincent Traag, Fabio Zanini, Daniel Noom, (2022). > *IGraph/M: graph theory and network analysis for Mathematica*. > arXiv:2209.09145 **[physics.soc-ph]**. > https://doi.org/10.48550/arXiv.2209.09145 [](https://igraph.discourse.group) [](https://github.com/szhorvat/IGraphM/releases) [](https://github.com/szhorvat/IGraphM#contributions) [](https://doi.org/10.5281/zenodo.1134932) ---- ##Article abstract IGraph/M is an efficient general purpose graph theory and network analysis package for Mathematica. IGraph/M serves as the Wolfram Language interfaces to the igraph C library, and also provides several unique pieces of functionality not yet present in igraph, but made possible by combining its capabilities with Mathematica's. The package is designed to support both graph theoretical research as well as the analysis of large-scale empirical networks. ---- ##Introduction The post below was written for the original release of IGraph/M. The package has come a long way since then and now contains ~300 functions. See http://szhorvat.net/mathematica/IGraphM for more details on the current release. Compatibility: 64-it Windows/macOS/Linux or Raspberry Pi; Mathematica <del>10.0</del> 11.0 or later. <a href="http://szhorvat.net/mathematica/IGraphM"><img src="https://community.wolfram.com//c/portal/getImageAttachment?filename=IGraphM-ad-3.png&userId=38370" width="300"></a> ---- I would like to announce IGraph/M, a new igraph interface for Mathematica: http://szhorvat.net/mathematica/IGraphM [igraph](http://igraph.org/) is a graph manipulation and analysis package. IGraph/M makes its functionality available from Mathematica. This initial release, version 0.1, covers only some igraph functions, as I focused on the things that I need personally. However the main framework is complete, and new functions can be added quickly. If anyone would like to contribute, please contact me. Binary packages for OS X (10.9 or later) and Linux can be downloaded [from GitHub](https://github.com/szhorvat/IGraphM/releases). Unfortunately, I was unable to compile the development version of igraph for Windows, so I cannot provide a Windows version. If you can help with compiling igraph itself (not IGraph/M) on Windows, please let me know! Functionality in this release that is not built into Mathematica: * Vertex betweenness centrality for weighted graphs * Estimates of vertex betweenness, edge betweenness and closeness centrality; for large graphs * Minimum feedback arc set for weighted and unweighted graphs * Find all cliques (not just maximal ones) * Count 3- and 4-motifs * Rewire edges, keeping either the density or the degree sequence * Alternative algorithms for isomorphism testing: Bliss, VF2 * Subgraph isomorphism * Test if a degree sequence is graphical * Alternative algorithms for generating random graphs with given degree sequence * Layout algorithms that take weights into account Note that IGraph/M is *not a replacement* for Mathematica's graphs and networks functionality. It is meant to complement what is already available in Mathematica, thus it primarily focuses on adding functionality that is not already present. Why did I release the package before covering most of the igraph functionality? I do not have time to work on things I do not personally need or use, so I am unlikely to extend it further unless the need comes up. I do think that the functions that are included in v0.1 can already be useful to others too. I would also like to give the opportunity for people to contribute to the project if they wish to. The groundwork has been laid, so further extensions should be quick and relatively easy. Also check out a related project, [IGraphR](https://github.com/szhorvat/IGraphR), which makes igraph available for Mathematica users through RLink. I wrote IGraph/M because I needed higher performance and greater reliability (especially for parallel computing) than what RLink could provide. ---- **A request:** If any of you have used IGraphR in the past to access igraph from Mathematica, please post a response to this thread and let me know which specific functions you were using. &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/94639221-60b4-47e3-8862-d996caa40388 Szabolcs Horvát 2015-09-06T12:55:14Z https://community.wolfram.com/groups/-/m/t/2983903 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=SudokuBlog-heroimage.png&userId=2028758 [2]: https://www.wolframcloud.com/obj/b9ea0b6a-1200-4c69-bd69-1e27edaa0a1b Alejandra Ortiz Duran 2023-08-04T23:54:58Z https://community.wolfram.com/groups/-/m/t/943673 Some time ago I saw a beautiful BBC documentary presented by an outstanding presenter, [Hannah Fry][1], on "[The Joy of Data][2]". She discussed a fascinating observation: If you start at a random wikipedia page, click on the first link in the main body of the article and then iterate, you will (with a probability of over 95%) end up at the [Wikipedia article on Philosophy][3]. There is a [wiki article that explains the phenomenon][4]; it also contains a link to an [online tool to check this observation][5] for a small number of starting pages. I think that one of the best descriptions of this phenomenon are in this [short clip from Hannah Fry's program][6]. Now, in this post I will show how to write a very crude crawler to generate networks like this: ![enter image description here][7] In a certain sense this post is in a similar spirit to a post by [@Sander Huisman][at0] on [Roads to Lyon][8] and another one by [@Bernat Espigulé Pons][at1] on the [Roads to Rome][9]. There is this article on [Letter Frequencies in Wikipedia][10] by [@Vitaliy Kaurov][at2] that animated me to write this post up now. Wikipedia is very special. It is fluid, keeps changing all the time and is a community effort that grows. First, primitive crawler ------------------------ The first thing we need to do is find the first link in each article. The Wolfram Language has Wikipedia data right built in, but I did not quite see a way of extracting the first link of the main body of the article. In WikipediaData["Scotland", "LinksRules"] the links are ordered alphabetically and therefore do not solve your problem. A first example --------------- Using a lit of (quite ugly) parsing and the powerful NestList we can get a sequence of links: NestList[(Select[Table[Quiet[("https://en.wikipedia.org/wiki" <> StringSplit[StringSplit[StringSplit[#, "<p>"][[k]], "<a href=\"/wiki"][[2]], "\""][[1]])], {k, 2, 10}], StringQ[#] &][[1]] &@ Import[#, "Source"]) &, "https://en.wikipedia.org/wiki/Germany", 30] Here we start at the article for Germany and "walk" for 30 steps. Here's the result: ![enter image description here][11] You actually see that we reach the article on Philosophy then move away and come back to it. So we end up at a sort of loop. Another problem is that we do not know for how long we have to walk before getting there (or not getting there?). We should rather use this function startGermany = NestWhileList[(Select[Table[Quiet[("https://en.wikipedia.org/wiki" <> StringSplit[StringSplit[StringSplit[#, "<p>"][[k]], "<a href=\"/wiki"][[2]], "\""][[1]])], {k, 2, 10}], StringQ[#] &][[1]] &@Import[#, "Source"]) &, "https://en.wikipedia.org/wiki/Germany", UnsameQ, All] ![enter image description here][12] We can plot this now: Graph[Rule @@@ Partition[StringDelete[startGermany, "https://en.wikipedia.org/wiki/"], 2, 1], VertexLabels -> "Name", ImageSize -> Full] ![enter image description here][13] We can clearly see how we move from the first article onto a loop. The loop is a sort of attractor of the system. In fact, what we really want to study is the "basin of attraction" of this attractor, i.e. which initial pages end up on this attractor. More systematic crawling approach The next thing is to find suitable starting pages. Here is an implementation which uses the "random page" function built into wikipedia: startingpages = Table[RandomChoice[Select[Import["https://en.wikipedia.org/wiki/Special:Random", "Hyperlinks"], (StringContainsQ[#, "https://en.wikipedia.org/wiki/"] && ! StringContainsQ[StringDelete[#, "https://en.wikipedia.org/wiki/"], ":"]) &]], {100}]; These are the articles that were randomly chosen when I ran the code: DeleteDuplicates[StringDelete[startingpages, "https://en.wikipedia.org/wiki/"]] ![enter image description here][14] Now we need to get the data. The paths of the 100 pages are relatively quick to generate: Monitor[paths = Table[NestWhileList[(Select[Table[Quiet[("https://en.wikipedia.org/wiki" <> StringSplit[StringSplit[StringSplit[#, "<p>"][[k]], "<a href=\"/wiki"][[2]], "\""][[1]])], {k, 2, 10}], StringQ[#] &][[1]] &@Import[#, "Source"]) &, startingpages[[m]], UnsameQ, All], {m, 1, Length[startingpages]}];, m] Note, that when you run the code you should add a Pause[...] so that you do not put the Wikipedia server under pressure. Just to be safe, I would rather also export the data, after the download: Export["~/Desktop/startingpagessmall.mx", startingpages]; Export["~/Desktop/paths.mx", paths]; We can now plot the result of our first analysis. HighlightGraph[ Graph[DeleteDuplicates[ Flatten[Rule @@@ Partition[StringDelete[#, "https://en.wikipedia.org/wiki/"], 2,1] & /@ paths]], Background -> Black, VertexStyle -> Yellow, EdgeStyle -> LightYellow, VertexSize -> 2, ImageSize -> Full], "Philosophy"] ![enter image description here][15] The red vertex represents the Philosophy article. It becomes clear that it is on a cycle - the same cycle we have observed for the case of Germany as initial page. If we remove the link from Philosophy to Greek_language we end up with images like these: HighlightGraph[ Graph[DeleteCases[DeleteDuplicates[ Flatten[Rule @@@ Partition[StringDelete[#, "https://en.wikipedia.org/wiki/"], 2, 1] & /@ paths]], "Philosophy" -> "Greek_language"], Background -> Black, VertexStyle -> Yellow, EdgeStyle -> LightYellow, VertexSize -> 2, ImageSize -> Full, GraphLayout -> "RadialEmbedding"], "Philosophy"] ![enter image description here][16] All paths on the largest component of the graph end up at the red point. Plotting this as a rooted graph makes the structure a bit clearer: HighlightGraph[Graph[WeaklyConnectedGraphComponents[Graph[DeleteCases[DeleteDuplicates[Flatten[Rule @@@ Partition[StringDelete[#, "https://en.wikipedia.org/wiki/"], 2, 1] & /@ paths]], "Philosophy" -> "Greek_language"]]][[1]], Background -> Black, VertexStyle -> Yellow, EdgeStyle -> LightYellow, VertexSize -> 0.4, ImageSize -> Full, GraphLayout -> {"LayeredEmbedding", "RootVertex" -> "Philosophy"}], "Philosophy"] ![enter image description here][17] We can of course label the nodes, but this overloads the image somewhat: Graph[DeleteDuplicates[Flatten[Rule @@@ Partition[StringDelete[#, "https://en.wikipedia.org/wiki/"], 2, 1] & /@ paths]], VertexLabels -> "Name", VertexLabelStyle -> Directive[7], VertexSize -> 2, ImageSize -> Full] ![enter image description here][18] Here's a 3D version: Graph3D[DeleteDuplicates[Flatten[Rule @@@ Partition[StringDelete[#, "https://en.wikipedia.org/wiki/"], 2, 1] & /@ paths]], VertexSize -> 2, ImageSize -> Full] ![enter image description here][19] A more comprehensive dataset ---------------------------- For a slightly more detailed analysis I will need more starting wiki pages. startingpages1000 = DeleteDuplicates[Table[RandomChoice[Select[Import["https://en.wikipedia.org/wiki/Special:Random", "Hyperlinks"], (StringContainsQ[#, "https://en.wikipedia.org/wiki/"] && ! StringContainsQ[StringDelete[#, "https://en.wikipedia.org/wiki/"], ":"]) &]], {1200}]]; The next function should only be run with an appropriate Pause between the calls - **Be nice to Wikipedia!** It is an absolutely brilliant resource for everyone. Monitor[paths1000 = Table[NestWhileList[(Select[Table[Quiet[("https://en.wikipedia.org/wiki" <> StringSplit[StringSplit[StringSplit[#, "<p>"][[k]], "<a href=\"/wiki"][[2]], "\""][[1]])], {k, 2, 10}], StringQ[#] &][[1]] &@Import[#, "Source"]) &, startingpages1000[[m]], UnsameQ, All], {m, 1, Length[startingpages1000]}];, m] The code will run for many hours or days if you choose a good waiting time between calls. Let's save that again: Export["~/Desktop/startingpages1000.mx", startingpages1000]; Export["~/Desktop/paths1000.mx", paths1000]; Let's prepare the data for further analysis: paths1000clean = (Select[Select[Select[#, StringQ], ! StringContainsQ[#, "wiki<a href="] &], (StringContainsQ[#, "https://en.wikipedia.org/wiki/"] && ! StringContainsQ[StringDelete[#, "https://en.wikipedia.org/wiki/"], ":"]) &]) & /@ paths1000; Here's the resulting graph: HighlightGraph[Graph[WeaklyConnectedGraphComponents[Graph[DeleteDuplicates[Flatten[(Rule @@@ Partition[StringDelete[#, "https://en.wikipedia.org/wiki/"], 2, 1]) & /@ paths1000clean]]]][[1]], VertexStyle -> Yellow, EdgeStyle -> Yellow], Graph[(Rule @@@ Partition[StringDelete[startGermany, "https://en.wikipedia.org/wiki/"], 2,1])[[6 ;;]]], Background -> Black] ![enter image description here][20] As a matter of fact, this is only the largest connected component of the graph. If we cut again the outgoing link from the Philosophy article and plot everything we get: HighlightGraph[Graph[DeleteCases[DeleteDuplicates[Flatten[(Rule @@@ Partition[StringDelete[#, "https://en.wikipedia.org/wiki/"], 2, 1]) & /@ paths1000clean]], "Philosophy" -> "Greek_language"], ImageSize -> Full, Background -> Black, EdgeStyle -> Yellow, VertexStyle -> Yellow], "Philosophy"] ![enter image description here][21] We have Length[paths1000] 1073 starting pages and there are Length[WeaklyConnectedComponents[Graph[DeleteCases[DeleteDuplicates[Flatten[(Rule @@@ Partition[StringDelete[#, "https://en.wikipedia.org/wiki/"],2, 1]) & /@ paths1000clean]], "Philosophy" -> "Greek_language"], ImageSize -> Full, Background -> Black, EdgeStyle -> Yellow, VertexStyle -> Yellow]]] 65 weakly connected components. This allows us to estimate (it is actually not the true value) that about (1073 - 64)/1073. or 94% of all websites lead to the Philosophy article, which is in relatively good agreement with the [data on this website][22], where they obtain 97% - the difference might be in part due to my crude parsing and also because I use slightly different rules than they do. Also, I only use only a very small subset of all 5 million plus pages. Nevertheless, there is evidence for a large attractor. HighlightGraph[Graph[WeaklyConnectedGraphComponents[Graph[DeleteCases[DeleteDuplicates[Flatten[(UndirectedEdge @@@ Partition[StringDelete[#, "https://en.wikipedia.org/wiki/"], 2, 1]) & /@ paths1000clean]], "Philosophy" -> "Greek_language"]]][[1]], Background -> Black, VertexStyle -> Yellow, EdgeStyle -> LightYellow, VertexSize -> 0.1, ImageSize -> Full, GraphLayout -> {"LayeredEmbedding", "RootVertex" -> "Philosophy"}], "Philosophy", ImagePadding -> 10, AspectRatio -> 1/2] ![enter image description here][23] Note that we could of course take any other page on our attractor Graph[(Rule @@@ Partition[StringDelete[startGermany, "https://en.wikipedia.org/wiki/"], 2, 1])[[6 ;;]], VertexLabels -> Placed["Name", Above], VertexStyle -> Yellow, EdgeStyle -> Yellow, VertexLabelStyle -> Directive[Yellow, 20], Background -> Black] ![enter image description here][24] as the target state. But it sounds much nicer to claim that ***the greatest collection of human knowledge all leads to Philosophy***. If you were inclined to do so you could also claim that it leads to the "international phonetic alphabet" or to "science". I have a tendency for the latter and therefore want to add the respective graph plot: HighlightGraph[Graph[WeaklyConnectedGraphComponents[Graph[DeleteCases[DeleteDuplicates[Flatten[(UndirectedEdge @@@ Partition[StringDelete[#, "https://en.wikipedia.org/wiki/"], 2, 1]) & /@ paths1000clean]], "Science" -> "Knowledge"]]][[1]], Background -> Black, VertexStyle -> Yellow, EdgeStyle -> LightYellow, VertexSize -> 0.1, ImageSize -> Full, GraphLayout -> {"LayeredEmbedding", "RootVertex" -> "Science"}], "Science", ImagePadding -> 10, AspectRatio -> 1/2] ![enter image description here][25] Some basic characteristics of the network ----------------------------------------- We can now also make some simple calculations about properties of these graphs. First we try to find out which node represents the Philosophy article: Position[VertexList[WeaklyConnectedGraphComponents[Graph[DeleteCases[DeleteDuplicates[Flatten[(Rule @@@ Partition[StringDelete[#, "https://en.wikipedia.org/wiki/"], 2, 1]) & /@ paths1000clean]], "Philosophy" -> "Greek_language"]]][[1]]], "Philosophy"] which gives 320. Next we can calculate the distance matrix between all nodes: distmatrix = GraphDistanceMatrix[WeaklyConnectedGraphComponents[Graph[DeleteCases[DeleteDuplicates[Flatten[(Rule @@@ Partition[StringDelete[#, "https://en.wikipedia.org/wiki/"], 2, 1]) & /@ paths1000clean]], "Philosophy" -> "Greek_language"]]][[1]]]; and check the distance of all other articles to the Philosophy article: dist2philosophy = Transpose[distmatrix][[320]]; What's the mean path length? N@Mean[dist2philosophy] which gives 14.6. The median N@Median[dist2philosophy] is 15. These values are lower than the ones reported on the [page above][26], which gives a median length of 23. We can also plot a histogram Histogram[dist2philosophy, PlotTheme -> "Marketing", FrameLabel -> {"Path length", "Number of paths"}, LabelStyle -> Directive[Bold, Medium], ChartStyle -> Red, ImageSize -> Large] ![enter image description here][27] Well, this is not too bad, but it does not seem to correspond perfectly to what is reported either. I do use slightly different rules though. *I am currently working on a much more efficient way of doing this with the Wolfram Language. If it works I might post it later.* Disclaimer & what to do if you want to reproduce that ----------------------------------------------------- Note, that you should not run the crawler without a delay between consecutive requests. To allow you to run the code, I will add the files with the data I have downloaded. Discussion ---------- *The explanation for this curious structure of the nearly global attractor is still not quite clear. There are hypothesis such as the fact that authors are encouraged to start an article by a definition of the topic of the article. This might lead to a sort of classification chain which ends up at areas such as Philosophy and Science. Differently from the standard procedure my paring does maintain links to the phonetical transcription. What is interesting is that in spite of several differences between my and the standard procedure the main effect of ending up at Philosophy (or Science) is still there and hence appears to be robust with respect to smaller changes in the algorithm - and that's quite cool.* Cheers, Marco [at0]: http://community.wolfram.com/web/sghuisman [at1]: http://community.wolfram.com/web/bernatep [at2]: http://community.wolfram.com/web/vitaliyk [1]: http://www.hannahfry.co.uk [2]: http://www.bbc.co.uk/programmes/b07lk6tj [3]: https://en.wikipedia.org/wiki/Philosophy [4]: https://en.wikipedia.org/wiki/Wikipedia:Getting_to_Philosophy [5]: http://xefer.com//wikipedia [6]: http://www.bbc.co.uk/programmes/p0418hfr [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-14at23.54.44.png&userId=48754 [8]: http://community.wolfram.com/groups/-/m/t/758828 [9]: http://community.wolfram.com/groups/-/m/t/758936 [10]: http://community.wolfram.com/groups/-/m/t/942423 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-15at00.04.18.png&userId=48754 [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-15at00.07.31.png&userId=48754 [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-15at00.08.27.png&userId=48754 [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-15at00.14.20.png&userId=48754 [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-15at00.19.53.png&userId=48754 [16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-15at00.23.03.png&userId=48754 [17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-15at00.25.55.png&userId=48754 [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-15at00.27.27.png&userId=48754 [19]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3DWiki.gif&userId=48754 [20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-15at00.38.13.png&userId=48754 [21]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-15at00.40.45.png&userId=48754 [22]: https://en.wikipedia.org/wiki/Wikipedia:Getting_to_Philosophy [23]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-15at00.49.48.png&userId=48754 [24]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-15at00.51.22.png&userId=48754 [25]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-15at00.54.59.png&userId=48754 [26]: https://en.wikipedia.org/wiki/Wikipedia:Getting_to_Philosophy [27]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-15at01.02.53.png&userId=48754 Marco Thiel 2016-10-15T00:25:30Z https://community.wolfram.com/groups/-/m/t/1707390 ![mapplot1: place of death of the oldest people][6] Abstract -------- The world's oldest people reflect the underlying medical, technological, and socio-economical conditions of their places of residence. The oldest people on record are ten times more likely to be females than males, supporting the traditional hypothesis that females make less risky social choices. Although all broad racial groups are represented, more than half of the oldest people on record since 1842 are white, and eighty percent was born in G8 countries, indicating the earlier advancement of Western European and North American's healthcare system. Similarly, the oldest people are clustered in Eastern United States, Japan, Britain, and France, justifying the correlation between socio-economical development and increased life-span. Furthermore, the world's oldest people are living longer - by an average of 1.11 years each decade, which demonstrates the overall improvement of global living conditions. The influence of socio-economic conditions on longevity suggests many directions to improve life-span around the world. ---------- I. Data Import -------------- The list of worlds' oldest people, curated by Gerontology Research Group, was imported directly into Wolfram Mathematica using the following code: ClearAll["Global`*"]; rawData1 = Import["http://archive.is/4kwbk", "Data"]; The data table - the only element of interest from the website - was located by trial and error: it is in the level [[2,2,1]], from position 8 to position 71. In case the data table would be updated in the future, a While loop was implemented to locate the table's last line: count = 71; continue = True; While[And[continue == True, count < Length[rawData1[[2, 1, 1]]]], If[NumberQ[First[rawData1[[2, 1, 1]][[count]]]], count++, continue = False ]]; Since the last line of the data table describes the current oldest person, with missing date of death/Most recent alive date, it was separately processed - adding the current date, and manually appended into the table: rawData2 = Take[rawData1[[2, 1, 1]], {8, count - 2}]; lastLine = Insert[rawData1[[2, 1, 1, count - 1]], DateString["ISODate"], 5]; AppendTo[rawData2, lastLine]; This raw data table was not usable, as it contained disparage type of data in one cell or column: separating the years and days of age, mixing up cities and countries, including annotation [] and parentheses () within data. Furthermore, it gave secondary/derived data: age, which could be obtained from date of birth and most recent alive date. Hence, the data was cleaned up: rawData3 = Extract[Transpose[ Sort[rawData2, #1[[4]] < #2[[4]] &]], {#} & /@ {1, 2, 3, 4, 5, 8, 9, 10}]; cleanfunc[s_] := StringReplace[ s, {" [" ~~ x___ ~~ "]" -> "", "(" ~~ x___ ~~ ")" -> x}]; cleanfuncRace[s_] := StringReplace[ s, {"W" -> "white", "B" -> "black", "EA" -> "asian", "O" -> "asian", "M" -> "multiracial", "H" -> "hispanic"}]; cleanfuncSex[s_] := StringReplace[s, {"M" -> "male", "F" -> "female"}]; cleanStrings = {"Que" -> "Quebec", "GA" -> "Georgia", "now Poland" -> "", "British West Indies now Jamaica" -> "Jamaica", "U.S. MI" -> "Michigan", "Cape Verde Portugal" -> "Cape Verde", "France St. Barts" -> "Saint Barthelemy"}; The data table received additional attributes - Date Object or City/Country Entity - thanks to SemanticInterpretation[]. In order to implement SemanticInterpretation[], certain strings were removed or clarified, as detailed above. Nevertheless, SemanticInterpretation[] may fail in some instance, which then requires the re-implementation of the following block of code: rawData4 = Transpose[{rawData3[[1]], cleanfunc[rawData3[[3]]], SemanticInterpretation[cleanfunc[rawData3[[4]]]], SemanticInterpretation[rawData3[[5]]], cleanfuncRace[cleanfunc[rawData3[[6]]]], rawData3[[7]], SemanticInterpretation[ StringReplace[cleanfunc[rawData3[[2]]], cleanStrings]], SemanticInterpretation[ StringReplace[cleanfunc[rawData3[[8]]], cleanStrings]]}]; dataNoHeading = Transpose[ Insert[Transpose[rawData4], Table[DateDifference[rawData4[[i, 3]], rawData4[[i, 4]], {"Year", "Day"}], {i, 1, Length[rawData4]}], 5]]; headings = {"No.", "Name", "Date of birth", "Most recent alive date", "Age", "Race", "Sex", "Birthplace", "Deathplace"}; data = Prepend[dataNoHeading, headings]; data // TableForm Upon successful running of SemanticInterpretation[], the data table appeared as follow: ![Part of the data table][1] II. Data Visualizations and Analysis ----------------------- The oldest people are more likely to be women than men, with a ratio of ten-to-one (pieChart1). This discrepancy underscores socio-environmental choices of each gender: men tend to engage in more risky activities: smoking, drinking, using drugs, reckless driving, ignoring health issues, working in dangerous occupations, participating in war, etc. (This gender discrepancy might be attributed to biological differences between male and female also: women were observed to have more resistance to infections and degenerative diseases than men.) genderCounts = Counts[Transpose[dataNoHeading][[7]] //. {"F" -> "Female", "M" -> "Male"}]; genderPercentage = genderCounts/Total[Values[genderCounts]]; pieChartLabel1 = Table[Style[ StringJoin[Keys[genderPercentage][[n]], " ", ToString[Round[Values[genderPercentage][[n]]*100, 1]], "%"], Bold, 14], {n, 1, Length[genderPercentage]}]; pieChart1 = PieChart[Counts[Transpose[dataNoHeading][[7]]], ChartLabels -> pieChartLabel1, ChartStyle -> {Lighter[Pink], Lighter[Blue]}, PlotLabel -> Style[Framed["Gender distribution of the worlds' oldest people"], 16]] ![pieChart1: the gender composition of the oldest people][2] Among all the racial groups - Black, White, Asian, Hispanic, the oldest people are more than half as likely to be White (barChart1). This skewed racial representation may attest to the fact that North American and European countries industrialized earlier than the rest of the world. Accordingly, the oldest people are four times as likely to have been born in G8 countries - the more developed, more resourceful nations of the world (barChart2). Furthermore, the oldest people who come from the same country tend to have similar age, which suggests some influence of environmental conditions (clusterImage1). Following the trend, the oldest people's last place of residence tend to cluster around Eastern United States, Europe, or Japan, where advance, life-extending medical services are available. Hence, the racial, place-of-birth, and place-of-death composition of the oldest people all imply that socio-economic conditions greatly affect life-span. (Again, the contribution of genetic, biological factors cannot be discounted - neither is the fact that more develop countries keep better record/census of their people.) raceCounts = Counts[Transpose[dataNoHeading][[6]]]; racePercentage = raceCounts/Total[Values[raceCounts]]; barChartLabel1 = Table[Style[ Framed[StringJoin[Keys[racePercentage][[n]], " ", ToString[Round[Values[racePercentage][[n]]*100, 1]], "%"] ], 12], {n, 1, Length[racePercentage]}]; barChart1 = BarChart[raceCounts, ChartLabels -> barChartLabel1, AxesLabel -> {"Race", "Counts"}, ChartStyle -> {White, Orange, Black, Brown, Gray}, PlotLabel -> Style[Framed["Racial distribution of the worlds' oldest people"], 16], ImageSize -> Large] ![barChart1: racial distribution of the world oldest people][3] EntityValue[Entity["HistoricalCountry", "Czechoslovakia"], "Flag"] = EntityValue[Entity["Country", "CzechRepublic"], "Flag"]; birthPlaceList = Transpose[dataNoHeading][[8]]; birthCountryList = Table[If[EntityTypeName[birthPlaceList[[i]]] == "Country" || EntityTypeName[birthPlaceList[[i]]] == "HistoricalCountry", birthPlaceList[[i]], birthPlaceList[[i]]["Country"]], {i, 1, Length[birthPlaceList]}]; deathPlaceList = Transpose[dataNoHeading][[9]]; deathCountryList = Table[If[EntityTypeName[deathPlaceList[[i]]] == "Country" || EntityTypeName[deathPlaceList[[i]]] == "HistoricalCountry", deathPlaceList[[i]], deathPlaceList[[i]]["Country"]], {i, 1, Length[deathPlaceList]}]; f[x_] := Magnify[Framed[x], 0.1]; chartList2 = Sort[Counts[#]] & /@ GatherBy[birthCountryList, MemberQ[EntityList[EntityClass["Country", "G8"]], #] &]; chartList2Flag = Map[f, EntityValue[Keys[chartList2], "Flag"], {2}]; chartList2ForPlot = Table[Table[ Labeled[chartList2[[n, m]], chartList2Flag[[n, m]]], {m, 1, Length[chartList2[[n]]]}], {n, 1, Length[chartList2]}]; barChart2GroupLabel = {Placed[{Style[Framed["G8"], 14], Style[Framed["non G8"], 14]}, Above], Automatic}; barChart2 = BarChart[chartList2ForPlot, ChartStyle -> "Pastel", ChartLabels -> barChart2GroupLabel, AxesLabel -> {"Country", "Counts"}, PlotLabel -> Style[Framed["Birth country of the worlds' oldest people"], 16], ImageSize -> Large] ![barChart2: birth country of the oldest people][4] clusterFlagLabel = Magnify[Framed[#], 0.1] & /@ EntityValue[birthCountryList, "Flag"]; clusterImage1 = ClusteringTree[ UnitConvert[Drop[data[[All, 5]], 1], "Year"] -> clusterFlagLabel, ClusterDissimilarityFunction -> "Centroid", GraphLayout -> "RadialEmbedding", PlotLabel -> Style[Framed[ "Cluster by age of the oldest people\nwith respect to their \ birthplace "], 16], ImageSize -> Large] ![clusterImage1: cluster by age of the oldest people][5] mapPlot1 = GeoGraphics[{GeoMarker[deathPlaceList, EntityValue[Entity["Icon", "MensRoom"], "Image"]]}, GeoRange -> "World", GeoBackground -> "Coastlines", GeoProjection -> "Robinson", ImageSize -> Full, PlotLabel -> Style[Framed[ "Current residence or place of death since 1955\nof the world's \ oldest people"], 20]] ![mapplot1: place of death of the oldest people][6] Finally, the oldest people are living longer: the linear model for date of birth and age predicts that age would increase by 1.11 years each decade (listPlot1). This trend of increment in the oldest people's life-span correlates with better living conditions worldwide. dateOfBirthAgeList = TimeSeries[ Transpose[ Append[{Transpose[dataNoHeading][[3]]}, QuantityMagnitude[ UnitConvert[Transpose[dataNoHeading][[5]], "Year"]]]]]; datePairList = dateOfBirthAgeList["Path"]; modelFit = LinearModelFit[dateOfBirthAgeList, x, x]; modelFitList = Table[{x, modelFit[x]}, {x, First[datePairList][[1]], Last[datePairList][[1]], ( Last[datePairList][[1]] - First[datePairList][[1]])/50}]; plotlabel = Style[Framed[ "Date of birth and age of the oldest people, in blue\nwith \ best-fitted line in dashed orange"], 16]; listPlot1 = DateListPlot[{dateOfBirthAgeList, modelFitList}, PlotLabel -> plotlabel, FrameLabel -> {"Date of Birth", "Age"}, PlotStyle -> {Thick, {Thick, Dashed}}, Joined -> {False, True}, PlotMarkers -> {All, None}, ImageSize -> Large] ageDifference = modelFit[10*365.25*24*60*60] - modelFit[0]; rSquare = modelFit["RSquared"]; Print["The best-fitted linear model predicts that the oldest people's \ age would increase by ", ageDifference, " years each decade."]; ![listPlot1: Date of birth and age of oldest people][7] In conclusion, the oldest people are predominantly women, are mostly white, and are very likely to be born or lived in developed countries. The gender, racial, and geographical distribution of the oldest people show the impact of socio-economical conditions on life-span. The age of the oldest people is increasing, correlating with the overall advances in technology and healthcare. The correlation between (the number of) oldest people and improved living conditions suggests certain directions to improve life-span in less-developed parts of the world: providing healthcare, improving living conditions, discouraging/alleviating (male) idiosyncratic choices, investing in research and development, etc. Bonus ----- Dynamic plot/video of the oldest people: ClearAll[beginDate, endDate, beginYear, endYear, listLiveDeath, listLive, listDeath, plotMap, geoLive, geoGold, geoRed, geoBlue, listDate, listDateValue]; beginDate = First[dataNoHeading][[3]] - Quantity[1, "years"]; endDate = Last[data][[4]] + Quantity[0, "years"]; beginYear = DateObject[beginDate, "Year"]; endYear = DateObject[endDate, "Year"]; dayRange = QuantityMagnitude[UnitConvert[endDate - beginDate, "Days"]]; listDate = Union[Transpose[dataNoHeading][[3]], Transpose[dataNoHeading][[4]]]; listDateValue = QuantityMagnitude[ UnitConvert[DateDifference[beginDate, #] & /@ listDate, "Days"]]; plotMap[time_] := plotMap[time] = Module[{t = time, listDeath, listLive, timeDeathPlaceListDeath, timeDeathPlaceListLive, geoLive, geoBlue, plotLabel}, {listLive = Select[dataNoHeading, And[QuantityMagnitude[ DateDifference[#[[3]], beginYear + Quantity[t, "days"]]] >= 0, QuantityMagnitude[ DateDifference[#[[4]], beginYear + Quantity[t, "days"]]] <= 0] &]; plotLabel = Style[Framed[ "The world's oldest people who are still alive at time t\n\ Blue: the oldest person, Red: people who are going to be oldest"], 20]; Which[ Length[listLive] == 0, {GeoGraphics[GeoRange -> "World", GeoBackground -> "Coastlines", GeoProjection -> "Robinson", ImageSize -> Full, PlotLabel -> plotLabel] }, Length[listLive] == 1, {timeDeathPlaceListLive = Transpose[listLive][[9]]; geoBlue = GeoMarker[First[timeDeathPlaceListLive], EntityValue[Entity["Icon", "MensRoom"], "Image"], "Color" -> Blue, "Scale" -> Scaled[0.04]]; GeoGraphics[{geoBlue}, GeoRange -> "World", GeoBackground -> "Coastlines", GeoProjection -> "Robinson", ImageSize -> Full, PlotLabel -> plotLabel] }, Length[listLive] > 1, {timeDeathPlaceListLive = Transpose[listLive][[9]]; geoBlue = GeoMarker[First[timeDeathPlaceListLive], EntityValue[Entity["Icon", "MensRoom"], "Image"], "Color" -> Blue, "Scale" -> Scaled[0.04]]; geoLive = GeoMarker[Drop[timeDeathPlaceListLive, 1], EntityValue[Entity["Icon", "MensRoom"], "Image"]]; GeoGraphics[{geoBlue, geoLive}, GeoRange -> "World", GeoBackground -> "Coastlines", GeoProjection -> "Robinson", ImageSize -> Full, PlotLabel -> plotLabel] }] }]; Table[plotMap[t], {t, listDateValue}]; Hold[ plotMap[time_] := plotMap[time] = Module[{t = time, listDeath, listLive, timeDeathPlaceListDeath, timeDeathPlaceListLive, geoLive}, {listLive = Select[dataNoHeading, And[QuantityMagnitude[ DateDifference[#[[3]], beginYear + Quantity[t, "days"]]] >= 0, QuantityMagnitude[ DateDifference[#[[4]], beginYear + Quantity[t, "days"]]] <= 0] &]; If[listLive == {}, {GeoGraphics[GeoRange -> "World", GeoBackground -> "Coastlines", GeoProjection -> "Robinson", ImageSize -> Full, PlotLabel -> Style[Framed[ "The world's oldest people who are still alive at time \ t"], 20]]}, {timeDeathPlaceListLive = Transpose[listLive][[9]]; geoLive = {GeoMarker[timeDeathPlaceListLive, EntityValue[Entity["Icon", "MensRoom"], "Image"]]}; GeoGraphics[geoLive, GeoRange -> "World", GeoBackground -> "Coastlines", GeoProjection -> "Robinson", ImageSize -> Full, PlotLabel -> Style[Framed[ "The world's oldest people who are still alive at time \ t"], 20]] }] }]; Table[plotMap[t], {t, 0, dayRange, 2000}]; ]; mapAnimate = Animate[plotMap[t], {t, listDateValue}, DefaultDuration -> 20, AnimationRunning -> False] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2019-06-06problemT1datatable.PNG&userId=1707333 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2019-06-06ProblemT1pieChart1.png&userId=1707333 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2019-06-06ProblemT1barChart1.png&userId=1707333 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2019-06-06ProblemT1barChart2.png&userId=1707333 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2019-06-06ProblemT1clusterImage1.png&userId=1707333 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2019-06-06ProblemT1mapPlot.png&userId=1707333 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2019-06-06ProblemT1listPlot1.png&userId=1707333 Nam Tran 2019-06-19T06:12:55Z https://community.wolfram.com/groups/-/m/t/1561288 **[Open in Cloud][1] | [See Original][2] | Download to Desktop via Attachments Below** ![enter image description here][3] &[Wolfram Notebook][4] [1]: https://www.wolframcloud.com/objects/wolfram-community/3D-version-of-the-built-in-VoronoiDiagram-by-Chip-Hurst [2]: https://mathematica.stackexchange.com/questions/18893/how-can-i-define-a-3d-version-of-the-built-in-voronoidiagram-voronoimesh-in-v10 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=chip2.png&userId=20103 [4]: https://www.wolframcloud.com/obj/fcd0f8eb-5939-43fa-a040-4b0705220700 Greg Hurst 2018-11-28T19:03:50Z https://community.wolfram.com/groups/-/m/t/559849 How do I change the colors and styles of two functions that are graphed on the same set of axes? The color and style needs to be different for each function, but they must be on the same graph. The screenshot I attached is what I have graphed so far. F[x] needs to be purple and dashed. And H[x] needs to be red and thick. (please help I've been trying to figure this out for 4 hours!) kendra s 2015-09-04T20:37:32Z https://community.wolfram.com/groups/-/m/t/1065956 ![enter image description here][1] &[Wolfram Notebook][2] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=lichtenberg.gif&userId=32203 [2]: https://www.wolframcloud.com/obj/2775a340-5dcd-445e-8949-2d92d2fa1aed Henrik Schachner 2017-04-19T10:34:55Z