https://community.wolfram.com RSS Feed for Wolfram Community showing ideas 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/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/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/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/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/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 https://community.wolfram.com/groups/-/m/t/1393719 Shakespearean sonnets are composed with the rhyme scheme *ABAB CDCD EFEF GG* , which means that each verse with the same label needs to rhyme. An example is the famous sonnet 18: > A: Shall I compare thee to a summer’s day? B: Thou art more lovely and more temperate. A: Rough winds do shake the darling buds of May, B: And summer’s lease hath all too short a date. > C: Sometime too hot the eye of heaven shines, D: And often is his gold complexion dimmed; C: And every fair from fair sometime declines, D: By chance or nature’s changing course untrimmed. > E: But thy eternal summer shall not fade, F: Nor lose possession of that fair thou ow’st, E: Nor shall Death brag thou wand’rest in his shade, F: When in eternal lines to time thou grow’st. > G: So long as men can breathe or eyes can see, G: So long lives this, and this gives life to thee. To analyse the rhymes we first import it into Mathematica: sonnets = Select[StringTrim@StringSplit[#, "\n"] & /@ StringSplit[ToLowerCase@Import@"Shakespeare's Sonnets.txt", "\n\n"], Length@# == 14 &]; *The file is attached below and we select only sonnets with 14 verses (there are 2 outside this pattern). The next step is the select the last word of each verse and remove punctuation: lastWords = Map[Last@*StringSplit, sonnets, {2}] //. s_String :> StringReplace[s, { RegularExpression@"[,.;:!?-]$" -> "", RegularExpression@"'(.+)'" -> "$1", RegularExpression@"(.+)[,.;:!?]'" -> "$1"} ]; *The code is a bit awkward, but it works... Using the rhyme scheme, we pair the words that rhyme to form a graph: data = Union@Flatten@Table[Thread[lastWords[[All, i]] \[DirectedEdge] lastWords[[All, i+If[i==13,1,2]]]], {i, {1,2,5,6,9,10,13}}]; We are now ready to plot a graph of the word rhymes and segment each graph since most of them are disjoint. (g=Graph[data]) // WeaklyConnectedComponents; Select[Union /@ %, Length@# > 6 &] // Reverse@*SortByLength; Manipulate[Subgraph[g, %[[i]], VertexLabels -> "Name", ImageSize -> 600], {i, 1, Length@%, 1}] In the graph bellow you can see that key ([kee]) rhymes with survey (ser-vey) in Shakespeare time, hence it was probably pronouced [key]. ![key][1] A more in deep analysis of this subject can be found in the NativLang video [What Shakespeare's English Sounded Like - and how we know][2]. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=key.png&userId=845022 [2]: https://www.youtube.com/watch?v=WeW1eV7Oc5A Thales Fernandes 2018-07-28T01:02:21Z https://community.wolfram.com/groups/-/m/t/1383630 During this year's Wolfram Summer Camp, being mentored by Christian Pasquel, I developed a tool that identifies chord sequences in music (from MIDI files) and generates a corresponding graph. The graph represents all [unique] chords as vertices, and connects every pair of chronologically subsequent chords with a directed edge. Here is an example of a graph I generated: ![Graph genehrated from Bach's prelude no.1 of the Well Tempered Klavier (Book I)][1] Below is a detailed account on the development and current state of the project, plus some background on the corresponding musical theory notions. #Introduction       **GOAL** | The aim of this project is to develop a utility that identifies chords (e.g. C Major, A minor, G7, etc.) from MIDI files, in chronological order, and then generates a graph for visualizing that chord sequence. In the graph, each vertex would represent a unique chord, and each pair chronologically adjacent chords would be connected by a directed edge (i.e. an arrow). So, for example, if at some point in the music that is being analyzed there is a transition from a major G chord to a major C chord, there would be an arrow that goes from the G Major chord to the C Major chord. Therefore, the graph would describe a [Markov chain][2] for the chords. The purpose of the graph is to visualize frequent chord sequences and progressions within a certain piece of music.       **MOTIVATION** | While brainstorming for project ideas, I don't know why, I had a desire to do something with graphs. Then I asked myself, "What are graphs good at modelling?". I mentally browsed through my areas of interest, searching for any that matched that requirement. One of my main interests is music; I am somewhat of a musician myself. And, in fact, [musical] harmony *is* a good subject to be modelled by graphs. Harmony, one of the fundamental pillars of music (and perhaps the most important), not only involves the chords themselves, but, more significantly, the *transitions* between those, which is what gives character to music. And directed graphs, and, specifically, Markov models, are a perfect match for transitions between states. ---------- #Some background *Skip this if you aren't interested in the musical theory part or if you already have a background in music theory!* ##What is a chord? A chord is basically a group of notes played together (contemporarily). Chords are the quanta of musical "feeling"; the typical—but somewhat naïve—example is the sensation of major chords sounding "happy" and minor chords sounding "sad" or melancholic (more on types of chords later). Types of chords are defined by the [intervals][3] (distance in pitch) between the notes. The *root* of a chord is the "most important" or fundamental note of the cord, in the sense that it is the "base" from which the aforementioned intervals are measured. In other words, the archetype of chord defines the "feel" and the general harmonic properties of the chord, while the root defines the pitch of the chord. So a "C Major" chord is a chord with archetype "major triad" (more on that later) built on the note C; i.e., its root is C. The *sequence* of chords in a piece constitutes its **harmony**, and it can convey much more complex musical messages or feelings than a single chord, just as in language: a single word does have meaning, but a sentence can have a much more complex meaning than any single word. ##Patterns in chord sequences The main difference that between language and music is that language, in general, has a much stricter structure (i.e. the order of words, a.k.a. syntax) than music: the latter is an art, and there are no predetermined rules to follow. But humans \[have a tendency to\] like patterns, and music wouldn't be so universally beloved if it didn't contain any patterns. This also explains the unpopularity of [atonal music][4] (example [here][5]). But even atonal music has patterns: it may do its best to avoid harmonic patterns, but it still contains some level of rythmic, textural or other kinds of patterns. This is why using graphs to visualize chord sequences is interesting: it is a semidirect way of identifying the harmonic patterns that distinguish different genres, styles, forms, pieces or even fragments of music. In my project, I have mainly focused on the "western" conception of tonal music, an particularly in its "classical" version (what I mean by "classical" is, in lack of a better definition, a classification that encompasses all music where the composer is, culturally, the most important artist). That doesn't mean this tool isn't apt for other types of music; it just means it will analyze it from this specific standpoint. In tonal music, the harmonic patterns are all related to a certain notion of "center of gravity": the [*tonic*][6], which is, in some way the music's harmonic "home". Classical (as in pre-XX-century) tonal music usually ends (and often starts) with the tonic chord. In fact, we can further extend the analogy with gravity by saying that music consists in a game of tension, in which the closer you are to the center of gravity (the tonic), the greater the "pull". In an oversimplified manner, the musical equivalent of the [Schwarzschild radius][7] is the [dominant chord][8]: it tends towards the tonic. Well, not really, because you *can* turn back from it—and in fact a lot of interesting harmonical sequences consist in doing just that. ##Some types of chords In "classical" music (see definition above), there are mainly these kinds of chords (based on the amount of unique notes they contain): triad chords (i.e. three-note chords), seventh chords (i.e. four-note chords; we'll see why they're called *seventh* in a bit), and ninth chords (five-note chords). There is another main distinction: major and minor chords (i.e. the cliché "happy" vs "sad" distinction). ###Triad chords Probably the most simple and frequent chord is the triad chord (either major or minor). Here is a picture of a major and a minor triad C chord (left to right): ![Major and minor triad C chords (ltr)][9] ###Seventh chords [Seventh chords][10] are called so because they contain a seventh [interval][11]. Their main significance is in dominant chords, where they usually appear in the major-triad-minor-seventh (a.k.a ["dominant"][12]) form. Another important seventh chord form is the fully diminished seventh chord (these will be relevant for the code later), which also tends to resolve ("resolve" is music jargon for "transition to a chord with less tension") to tonic. ![Seventh chords][13] ###Ninth chords Although not extremely frequent, they do appear in classical music. The most "popular" is the dominant ninth chord (an extension of the dominant 7th). An alternative for this chord is the minor ninth dominant chord (built from the same dominant 7th chord, but with a minor ninth instead). <br> ---------- #Algorithms and Code In this section I'm going to walk through my code in order of execution. Four main parts can be distinguished in my project: importing and preprocessing, splitting the note sequence into "chunks" to be analyzed as chords, identifying the chord in each of those chunks, and visualizing the whole sequence as a graph. ##First phase: importing and preprocessing the MIDI file The first operation that needs to be done is importing the MIDI file and preprocessing it. This includes selecting which elements to import from the file, converting them to a given simplified form, and performing any sorting, deletion of superfluous elements, or other modification that needs to be done. For this purpose I defined the function `importMIDI`: importMIDI[filename_String] := MapAt[Flatten[#, 1] &, MapAt[flattenAndSortSoundNotes, Import[(dir <> filename <> ".mid"), {{"SoundNotes", "Metadata"}}], 1], 2] Here `dir` stands for the directory where I saved all my MIDIs (to avoid having to type in the whole directory every time). Notice that we're importing the music as SoundNotes *and* the file's metadata—we will need it for determining the boundaries of measures (see below). The function `flattenAndSortNotes` does what it sound like: it converts the list of `SoundNote`s that `Import` returned into a flattened list of notes (i.e. a single track), sorted by their starting time. It also gets rid of anything that isn't necessary for chord identification (i.e. rhythmic sounds or effects). Consult the attached notebook for the explicit definition. Here is the format the sequence of notes is returned in (i.e. `importMIDI[...][[1]]`): {{"C4", {0., 1.4625}}, {"E4", {0.18125, 1.4625}}, {"G4", {0.36875, 0.525}}, <<562>>, {"G2", {105., 107.963}}, {"G4", {105., 107.963}}} Each sub-list represents a note. Its first element is the actual pitch; the second is a list that represents the timespan (i.e. start and end time in seconds). <br> ##Second phase: splitting the note sequence into chunks The challenge in this part of the project is knowing how to determine which notes form a single chord; i.e., where to put the boundary between one chord and the next. The solution I came up with is not optimal, but, until now, nothing better has occurred to me (suggestions are welcome!). It involves determining where each measure start/end lies in time from the metadata and splitting each of those into a certain amount of sub-parts; then the notes are grouped by the specific sub-part of the specific measure they pertain to. The rationale behind this is that chords in classical music tend to be well-contained within measures or rational fractions of these. This procedure is contained in the function `chordSequenceAnalyzeUsingMeasures`. I'm going to go over it quickly: chordSequenceUsingMeasures[midiData_List /; Length@midiData == 2, measureSplit_: 2, analyzer_String: "Heuristic"] := Block[{noteSequence, metadata, chunkKeyframes, chunkedSequence, result}, (*Separate notes from metadata*) noteSequence = midiData[[1]]; metadata = midiData[[2]]; Until here it's pretty self evident. (*Get measure keyframes*) chunkKeyframes = divideByN[ measureKeyframesFromMetadata[ metadata, (Last@noteSequence)[[2, 2]]], measureSplit]; Here the function `measureKeyframesFromMetadata` is called. It fetches all of the `TimeSignature` and `SetTempo` tags in the metadata and identifies the position of each measure from them. `divideByN` subdivides each measure by `measureSplit` (an optional argument with default value `2`). (*Chunk sequence*) chunkedSequence = {}; Module[{i = 1}, Do[ With[{k0 = chunkKeyframes[[j]], k1 = chunkKeyframes[[j + 1]]}, Module[{chunk = {}}, While[ i <= Length@noteSequence && ( k0 <= noteSequence[[i, 2, 1]] < k1 || k0 < noteSequence[[i, 2, 2]] <= k1 ), AppendTo[chunk, noteSequence[[i]]] i++;]; AppendTo[chunkedSequence, chunk] ] ], {j, Length@chunkKeyframes - 1}]]; chunkedSequence = DeleteCases[chunkedSequence, l_List /; Length@l == 0]; Once the measures' timespan has been determined, a list of "chunks" (lists of notes grouped by measure part) is generated. (*Call analyzer*) Switch[analyzer, "Deterministic", result = chordChunkAnalyze /@ chunkedSequence, "Heuristic", result = heuristicChordAnalyze /@ justPitch /@ chunkedSequence ]; result = resolveDiminished7th[Split[result][[All, 1]]] ] Finally, each chunk is sent to the chord analyzer function `heuristicChordAnalyze`, which I'll talk about in the next section, along with the currently mysterious `resolveDiminished7th`. Since this algorithm for "chunking" a note sequence doesn't work for everything, I also developed an alternative, more naïve approach: chordSequenceNaïve[midiData_List /; Length@midiData == 2, analyzer_String: "Heuristic", n1_Integer: 6, n2_Integer: 1] := Module[{noteSequence, chunkedSequence, result}, (*Separate notes from metadata*) noteSequence = midiData[[1]]; (*Chunk sequence*) chunkedSequence = Partition[noteSequence, n1, n2]; (*Call analyzer*) result = heuristicChordAnalyze /@ justPitch@chunkedSequence; result = resolveDiminished7th[Split[result][[All, 1]]] ] <br> ##Phase 3: identifying the chord from a group of notes This has been the main conceptual challenge in the whole project. After some unsucsessful ideas, with some suggestions from Rob Morris (one of the mentors), whom I thank, I ended up developing the following algorithm. It iterates through each note and assigns it a score that represents the likeliness of that note being the root of the chord based on the presence of certain indicators (i.e. notes the presence of which define a chord, to some degree), each of which with a different weight: having a fifth, having a third, a minor seventh... Then the note with the highest chord is assumed to be the root of the chord. In code: heuristicChordAnalyze[notes_List] := Block[{chordNotes, scores, root}, (*Calls to helper functions*) chordNotes = octaveReduce /@ convertToSemitones /@ notes // DeleteDuplicates; (*Scoring*) scores = Table[Total@ Pick[ (*Score points*) {24, 16, 16, 8, 2, 3, 1, 1, 10, 15, 15, 18}, (*Conditions*) SubsetQ[chordNotes, #] & /@octaveReduce /@ {{nt + 7}, {nt + 4}, {nt + 3}, {nt + 10}, {nt + 11}, {nt + 2}, {nt + 5}, {nt + 9}, {nt + 4, nt + 10}, {nt + 3, nt + 6, nt + 10}, {nt + 3, nt + 6, nt + 9}, {nt + 1, nt + 4, nt + 10}} ] (*Substract outliers*) - 18*Length@Complement[chordNotes, octaveReduce /@ {nt, 7 + nt, 4 + nt, 3 + nt, 10 + nt, 11 + nt, 2 + nt, 5 + nt, 9 + nt, 6 + nt}], {nt, chordNotes}]; (*Return*) root = Part[chordNotes, Position[scores, Max @@ scores][[1, 1]]]; {root, Which[ SubsetQ[chordNotes, octaveReduce /@ {root + 10 , root + 2, root + 5, root + 9}], "13", SubsetQ[chordNotes, octaveReduce /@ {root + 10, root + 2, root + 5}], "11", SubsetQ[chordNotes, octaveReduce /@ {root + 4, root + 10, root + 2}], "Dom9", SubsetQ[chordNotes, octaveReduce /@ {root + 4, root + 10, root + 1}], "Dom9m", SubsetQ[chordNotes, octaveReduce /@ {root + 11, root + 7, root + 3}], "m7M", SubsetQ[chordNotes, {octaveReduce[root + 11], octaveReduce[root + 4]}], "7M", SubsetQ[chordNotes, {octaveReduce[root + 10], octaveReduce[root + 4]}], "Dom7", SubsetQ[chordNotes, {octaveReduce[root + 10], octaveReduce[root + 7]}], "Dom7", SubsetQ[chordNotes, {octaveReduce[root + 10], octaveReduce[root + 6]}], "d7", SubsetQ[ chordNotes, {octaveReduce[root + 9], octaveReduce[root + 6]}], "d7d", SubsetQ[chordNotes, {octaveReduce[root + 10], octaveReduce[root + 3]}], "m7", MemberQ[chordNotes, octaveReduce[root + 4]], "M", MemberQ[chordNotes, octaveReduce[root + 3]], "m", MemberQ[chordNotes, octaveReduce[root + 7]], "5", True, "undef"]} ] ###A note on notation In this project I use the following abbreviations for chord notation (they're not in the standard format). "X" represents the root of the chord. - *X-**5*** = undefined triad chord (just the root and the fifth) - *X-**M*** = Major - *X-**m*** = minor - *X-**m7*** = minor triad with minor (a.k.a dominant) seventh - *X-**d7d*** = fully diminished 7thchord - *X-**d7*** = half diminished 7thchord - *X-**Dom7*** = Dominant 7th chord - *X-**7M*** = Major triad with Major 7th - *X-**m7M*** = minor triad with Major 7th - *X-**Dom9*** = Dominant 9th chord - *X-**Dom9m*** = Dominant 7th chord with a minor 9th - *X-**11*** = 11th chord - *X-**13*** = 13th chord ###Dealing with diminished 7th chords Now, on to `resolveDiminished7th`. What is this function on about? Well, recall the fully diminished seventh chords I mentioned in the Background section. Here's the problem: they're completely symmetrical! What I mean by that is that the intervals between subsequent notes are identical, even if you [invert][14] the chord. In other words, the distance in semitones between notes is constant (it's 3) and is a factor of 12 (distance of 12 semitones = octave). So, given one of these chords, there is no way to determine which note is the root just by analyzing the chord itself. In the context of our algorithm, every note would have the same score! At this point I thought: "How do humans deal with this?". And I concluded that the only way to resolve this issue is to have some contextual vision (looking at the next chord, particularly), which is how humans do it. So what `resolveDiminished7th` does is it brushes through the chord sequence stored in `result`, looking for fully diminished chords (marked with the string "d7d"), and re-assigns each of those a root by looking at the next chord: resolveDiminished7th[chordSequence_List] := Module[{result}, result = Partition[chordSequence, 2, 1] /. {{nt_, "d7d"}, c2_List} :> Which[ MemberQ[octaveReduce /@ {nt, nt + 3, nt + 6, nt + 9}, octaveReduce[c2[[1]] - 1]], {{c2[[1]] - 1, "d7d"}, c2}, MemberQ[octaveReduce /@ {nt, nt + 3, nt + 6, nt + 9}, octaveReduce[c2[[1]] + 4]], {{c2[[1]] + 4, "d7d"}, c2}, MemberQ[octaveReduce /@ {nt, nt + 3, nt + 6, nt + 9}, octaveReduce[c2[[1]] + 6]], {{c2[[1]] + 6, "d7d"}, c2}, True, {{nt, "d7d"}, c2}]; result = Append[result[[All, 1]], Last[result][[2]]] ] ##Phase 4: Visualization Basically, my visualization function (`visualizeChordSequence`) is fundamentally a highly customized call of the `Graph` function; so I'll just paste the code below and then explain what some parameters do: visualizeChords[chordSequence_List, layoutSpec_String: "Unspecified", version_String: "Full", mVSize_: "Auto", simplicitySpec_Integer: 0, normalizationSpec_String: "Softmax"] := Module[{purgedChordSequence, chordList, transitionRules, weights, graphicalWeights, nOfCases, edgeStyle, vertexLabels, vertexSize, vertexStyle, vertexShapeFunction, clip}, (*Preprocess*) Switch[version, "Full", purgedChordSequence = StringJoin[toNoteName[#1], "-", #2] & @@@ chordSequence, "Basic", purgedChordSequence = Split[toNoteName /@ chordSequence[[All, 1]]][[All, 1]]]; (*Amount of each chord*) chordList = DeleteDuplicates[purgedChordSequence]; nOfCases = Table[{c, Count[purgedChordSequence, c]}, {c, chordList}]; (*Transition rules between chords*) Switch[version, "Full", transitionRules = Gather[Rule @@@ Partition[purgedChordSequence, 2, 1]], "Basic", transitionRules =(*DeleteCases[*) Gather[Rule @@@ Partition[purgedChordSequence, 2, 1]](*, t_/; Length@t\[LessEqual]2]*) ]; (*Get processed weight for each transition*) weights = Length /@ transitionRules; If[normalizationSpec == "Softmax", graphicalWeights = SoftmaxLayer[][weights]];; graphicalWeights = If[Min@graphicalWeights != Max@graphicalWeights, Rescale[graphicalWeights, MinMax@graphicalWeights, {0.003, 0.04}], graphicalWeights /. _?NumericQ :> 0.03 ]; (*Final transition list*) transitionRules = transitionRules[[All, 1]]; (*Graph display specs*) clip = RankedMax[weights, 4]; edgeStyle = Table[(transitionRules[[i]]) -> Directive[Thickness[graphicalWeights[[i]]], Arrowheads[2.5 graphicalWeights[[i]] + 0.015], Opacity[Which[ weights[[i]] <= Clip[simplicitySpec - 2, {0, clip - 2}], 0, weights[[i]] <= Clip[simplicitySpec, {0, clip}], 0.2, True, 0.6]], RandomColor[Hue[_, 0.75, 0.7]], Sequence @@ If[weights[[i]] <= Clip[simplicitySpec - 1, {0, clip - 1}], { Dotted}, {}] ], {i, Length@transitionRules}]; vertexLabels = Thread[nOfCases[[All, 1]] -> (Placed[#, Center] & /@ (Style[#[[1]], Bold, Rescale[#[[2]], MinMax[nOfCases[[All, 2]]], Switch[mVSize, "Auto", {6, 20}, _List, 10*mVSize[[1]]/0.3*{1, mVSize[[2]]/mVSize[[1]]}]]] & /@ nOfCases))]; vertexSize = Thread[nOfCases[[All, 1]] -> Rescale[nOfCases[[All, 2]], MinMax[nOfCases[[All, 2]]], Switch[mVSize, "Auto", (Floor[Length@chordList/10] + 1)*{0.1, 0.3}, _List, mVSize]]]; vertexStyle = Thread[nOfCases[[All, 1]] -> Directive[Hue[0.53, 0.27, 1, 0.6], EdgeForm[Blue]]]; vertexShapeFunction = Switch[version, "Full", Ellipsoid[#1, {3.5, 1} #3] &, "Basic", Ellipsoid[#1, {2, 1} #3] &]; Graph[transitionRules, GraphLayout -> Switch[layoutSpec, "Unspecified", Automatic, _, layoutSpec], EdgeStyle -> edgeStyle, EdgeWeight -> weights, VertexLabels -> vertexLabels, VertexSize -> vertexSize, VertexStyle -> vertexStyle, VertexShapeFunction -> vertexShapeFunction, PerformanceGoal -> "Quality"] ] There are five main things to focus on in the above definition: the graph layout (passed as the argument `layoutSpec`), the edge thickness (defined in `edgeStyle`), the vertex size (defined in `vertexSize`), the version (passed as argument `version`) and the simplicity specification (`simplicitySpec`). The graph layout is a `Graph` option that can be specified in the argument `layoutSpec`. If `"Unspecified"` is passed, an automatic layout will be used. I find that the best layouts tend to be, in order of preference, "BalloonEmbedding" and "RadialEmbedding"; nevertheless, neither are a perfect fit for every piece. In the future I would like to to implement custom (i.e. pre-defined) positioning, so that I can design it in a way that best fits this project. The edge thickness is a function of the amount of times a certain transition between two chords has occurred in the chord sequence. There is an option (namely the `normalizationSpec` argument) to enable or disable using a Softmax function for assigning thicknesses to edges. This is due to the fact that for simple/short chord sequences, Softmax is actually counterproductive because it suppresses secondary but still top-ranked transitions; i.e., it assigns a very high thickness to the most frequent transition and a low thickness to all other transitions (even those that come in second or third in frequency ranking). But for large or complex sequences it is actually useful, because it "gets rid of" a lot of the \[relatively\] insignificant instances, thus making the output actually understandable (and not just a [jumbled mess of thick lines][15]). The vertex size is proportional to the number of occurrences of each particular chord (that is, without taking into account the transitions). It can also be specified manually by passing `vSize` as a list `{a,b}` such that `a` is the minimum size an `b` is the maximum. The `version` can be either `"Full"` or `"Basic"`; the default is `"Full"`. The `"Basic"` version consists of a simplified chord set in which only the root note of the chord is taken into account, and not the archetype. For example, all C chords (M, Dom7, m...) would be represented by a single `"C"` vertex. Finally, the simplicity specification (`simplicitySpec`) is a number that can be thought of, in some way, as a "noise" threshold: as it gets larger, fewer edges "stand out"—that is, more of the lower-significance ones are rendered with reduced opacity or are shown as dotted lines. This is useful for large or complex sequences. <br> ---------- #Some examples Here I will show some specific examples generated with this tool. I tried to use different styles of music for comparison. - **Bach**'s [prelude no.1][16] from the Well Tempered Clavier: ![Visualization of Bach's prelude no.1 ][17] - **Debussy**'s [*Passepied*][18] from the *Suite Bergamasque*: ![Visualization of Debussy's *Passepied*][19] - A "template" blues progression: ![Blues template][20] - **Beethoven**'s second movement from the *Pathétique* sonata (no.8): ![Beethoven][21] - Any "reggaeton" song (e.g. Despacito): ![Reggaeton][22] #Microsite Check out the form page (a.k.a. microsite) of this project [here][23]: https://www.wolframcloud.com/objects/lammenspaolo/Chord%20sequence%20visualization [![enter image description here][24]][23] Briefly, here is what each option does (see the section **Algorithms and code** for a more detailed explanation): - **Chunkifier funciton**: choose between splitting notes by measures or by a constant amount of notes - **Measure split factor**: choose into how many pieces you want to divide measures (each piece will be analyzed as a separate chord) - **Graph layout**: choose the layout option for the `Graph` call - **Normalization function**: choose whether to apply a Softmax function to the weights of edges (to make results clearer in case of complex sequences). - **Version**: choose "Full" for complete chord info (e.g. "C-M", "D-Dom7", "C-7M"...) or "Basic" for just the root of the chord (e.g. "C", "D"...) - **Vertex size**: specify vertex size as a list `{a,b}` where `a` is the minimum and `b` is the maximum size - **Simplicity parameter**: visual simplification of the graph (a value of 0 means no simplification is applied) <br> #Conclusions I have developed a functional tool to visualize chord sequences as graphs. It is far from perfect, though. In the future, I would like improving the positioning of vertices, being able to eliminate insignificant transitions from the graph altogether, and making other visual adjustments. Furthermore, I plan to refine and optimize the chord analyzer, as right now it is just an experimental version that isn't too accurate. A better "chunkifier" function could be developed too. Finally, I'd like to thank my mentor Christian Pasquel and all of the other WSC staff for this amazing opportunity. I'd also like to thank my music theory teacher, Raimon Romaní, for making me, over the years, sufficiently less terrible at musical analysis to be able to undertake this project. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Prelude.png&userId=1372342 [2]: https://en.wikipedia.org/wiki/Markov_chain "Wikipedia: Markov chain" [3]: https://en.wikipedia.org/wiki/Interval_(music) "Wikipedia: Interval" [4]: https://en.wikipedia.org/wiki/Atonality "Wikipedia: Atonality" [5]: https://youtu.be/L85XTLr5eBE "Schönberg's 4th string quartet on YouTube" [6]: https://en.wikipedia.org/wiki/Tonic_%28music%29 "Wikipedia: Tonic" [7]: http://astronomy.swin.edu.au/cosmos/S/Schwarzschild+Radius "Basic info on Schwartzschild radius" [8]: https://en.wikipedia.org/wiki/Dominant_(music) "Dominant chord" [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2548Macro_analysis_chords_on_C.jpg&userId=1372342 [10]: https://en.wikipedia.org/wiki/Seventh_chord "Wikipedia: Seventh chord" [11]: https://en.wikipedia.org/wiki/Interval_(music) "Wikipedia: Interval" [12]: https://en.wikipedia.org/wiki/Dominant_seventh_chord "Wikipedia: Dominant seventh" [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=images.png&userId=1372342 [14]: https://en.wikipedia.org/wiki/Inversion_(music)#Chords "Wikipedia: Inversion#Chords" [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Passepied.png&userId=1372342 "Jumbled mess!" [16]: https://www.youtube.com/watch?v=aengbLEFnM8 [17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Prelude.png&userId=1372342 [18]: https://www.youtube.com/watch?v=hDWbVP-5DSA "Passepied" [19]: http://community.wolfram.com//c/portal/getImageAttachment?filename=deb_pass2.png&userId=1372342 [20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Blues.png&userId=1372342 [21]: http://community.wolfram.com//c/portal/getImageAttachment?filename=pathetique.png&userId=1372342 [22]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Reggaeton.png&userId=1372342 [23]: https://www.wolframcloud.com/objects/lammenspaolo/Chord%20sequence%20visualization "Microsite" [24]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-19at1.53.02PM.png&userId=11733 Paolo Lammens 2018-07-14T05:10:03Z https://community.wolfram.com/groups/-/m/t/1744863 *Click on the image to zoom. Then click your browser back button to return to reading the post.* ---------- [![enter image description here][1]][2] ## Introduction ## [Chord diagrams][3] are an elegant way to represent inter-relationships between variables. I recently found myself wanting to visualize something like this using Mathematica, and after searching high and low for built-in capabilities/ stack-exchange answers*, I decided to code one up. Hopefully this will be useful to someone else in the future! ## Getting the Data ## A simple way to get a dataset to visualize in the required format, is to use the WeightedAdjacencyMatrix of an (edge-)weighted graph from ExampleData. I used the "EurovisionVotes" dataset, not least because it's dear to my heart, but also because it has a manageable number of vertices and adjacency matrix density (for aesthetic reasons which will become apparent later). ExampleData[{"NetworkGraph", "EurovisionVotes"}, "LongDescription"] > Eurovision Song Contest voting network. An edge from s to t means that the country s has given 10 or more points to a song by t. The number of occasions is stored in the EdgeWeight edge property. In-fact, for the same aesthetic reasons, I trimmed the dataset slightly by dropping weak dependencies (edge weights less than 3), and re-ordered the vertices based on their VertexDegree: eurovisionGraph = ExampleData[{"NetworkGraph", "EurovisionVotes"}, "FullGraph"] trimmedGraph = Block[{g = eurovisionGraph, ones = Position[ WeightedAdjacencyMatrix[eurovisionGraph]["NonzeroValues"], a_ /; a < 3]}, Graph[VertexList[g], Delete[EdgeList[g], ones], EdgeWeight -> Delete[WeightedAdjacencyMatrix[g]["NonzeroValues"], ones]]]; orderedGraph = Block[{g = trimmedGraph, zeros = Length[Cases[VertexDegree[trimmedGraph], 0]]}, Graph[Drop[VertexList[g][[Ordering[VertexDegree[g]]]], zeros], EdgeList[g], EdgeWeight -> WeightedAdjacencyMatrix[g]["NonzeroValues"]]]; ## Poincare Arcs ## The hardest (and most elegant) part of the visualization is making the asymmetric ribbon to connect two nodes. After playing around with Bezier curves for a bit, I eventually settled on using Poincare arcs, code shamelessly adapted by the excellent [Mathworld Article][4] (relevant part reproduced below): poincareArc[l0_List] := Module[{l = Sort[l0], dt, t, t1, t2, r, R, c}, dt = Abs[l[[1]] - l[[2]]]; If[dt > \[Pi], l = Sort[l + {0, -2 \[Pi]}]]; dt = Abs[l[[1]] - l[[2]]]; t = Plus @@ l/2; If[dt == Pi, Line[{{Cos[l[[1]]], Sin[l[[1]]]}, {Cos[l[[2]]], Sin[l[[2]]]}}], c = {Cos[t], Sin[t]}; r = Tan[dt/2]; R = Sec[dt/2]; t1 = ArcTan @@ ({Cos[l[[2]]], Sin[l[[2]]]} - R c); t2 = ArcTan @@ ({Cos[l[[1]]], Sin[l[[1]]]} - R c); If[t2 < t1, t2 += 2 Pi]; (*Circle[R c, r, {t1, t2}]*) (r {Cos[#], Sin[#]}) + (R c) & /@ Subdivide[t1, t2, 500] ]] Essentially, this construction guarantees the arc joining two points on our outer circle, will have perpendicular ends to the outer circle. This in-turn ensures that ribbons made out of Poincare arcs will not be crowded in the center, and will always form a convex shape. Graphics[{Thread[{RandomColor[50], poincareArc /@ RandomReal[{0, 2 \[Pi]}, {50, 2}]}], Circle[]}] ![enter image description here][5] ## Static Picture## We now proceed to post-process our WeightedAdjacencyMatrix (WAM) dataset to hold the starting and ending angles of each ribbon. We essentially want two things: 1. Each node should be represented by a wedge with width proportional to the total flow out of it (row-sums of WAM) 2. Each edge should be represented by two Poincare arcs connecting the starting and ending points of the two node wedges To do this, we rescale the WAM by going around the circle, leaving ~1° between each wedge. countries = VertexList[orderedGraph]; flags = CountryData[#, "Flag"] & /@ countries; cols = Most@*Blend@*DominantColors /@ flags; Thread[{countries, cols}] wam = Normal[WeightedAdjacencyMatrix[orderedGraph]]; wedgesWidth = Total[wam, {2}]; angles = Partition[ Rescale[Accumulate[ Append[Prepend[Riffle[wedgesWidth, 1.], 0], 1.]]] 2 \[Pi], 2]; wedges = Thread[{cols, Annulus[{0, 0}, {10, 11}, #] & /@ angles}]; innerCircle = Thread[{cols, Circle[{0, 0}, 9.9, #] & /@ angles}]; subPartitionAngles = MapThread[ Partition[Rescale[Accumulate[Prepend[#1, 0]], {0, #2}, #3], 2, 1] &, {wam, wedgesWidth, angles}]; The ribbons joining two nodes are then created using a Polygon (tried using FilledCurve too w/ little success, would appreciate any pointers as to how to make that work), colored by the starting vertex: Clear[ribbon] ribbon[a_, b_] := ribbon[a, b] = Block[{\[Theta]1 = subPartitionAngles[[a, b]], \[Theta]2 = subPartitionAngles[[b, a]], pacs, circle1, circle2, coordinates, primitives, curve}, pacs = poincareArc /@ Transpose[{\[Theta]1, Reverse[\[Theta]2]}]; circle1 = {Cos[#], Sin[#]} & /@ Subdivide[\[Theta]1[[1]], \[Theta]1[[2]], 500] ; circle2 = DeleteDuplicates[{Cos[#], Sin[#]} & /@ Subdivide[\[Theta]2[[1]], \[Theta]2[[2]], 500] ]; coordinates = Join @@ {pacs[[1]], circle1, pacs[[2]], circle2}; {cols[[a]], GeometricTransformation[Polygon[coordinates], ScalingTransform[{9.9, 9.9}]]}] nonzeroPositions = Position[wam, Except[0], {2}, Heads -> False]; backgroundChords = {Opacity[0.25], ribbon @@@ DeleteDuplicates[Sort /@ nonzeroPositions]}; Putting everything together: Graphics[{innerCircle, backgroundChords, wedges}, ImageSize -> 750] ![enter image description here][6] ## Interactive Diagram ## It's relatively straightforward to make this interactive using Mouseover: dynamicLabels = Table[Mouseover[ Rotate[Text[Style[CountryData[countries[[i]], "CountryCode"], 12], 11.5 {Cos[Mean[angles[[i]]]], Sin[Mean[angles[[i]]]]}], If[3 \[Pi]/2 > Mean[angles[[i]]] > \[Pi]/2, Mean[angles[[i]]] - \[Pi], Mean[angles[[i]]]]], {Rotate[ Text[Style[CountryData[countries[[i]], "CountryCode"], 12, Bold], 11.5 {Cos[Mean[angles[[i]]]], Sin[Mean[angles[[i]]]]}], If[3 \[Pi]/2 > Mean[angles[[i]]] > \[Pi]/2, Mean[angles[[i]]] - \[Pi], Mean[angles[[i]]]]], {Opacity[0.75], ribbon @@@ Select[nonzeroPositions, #[[1]] == i &]}} ], {i, Length[countries]}]; Which would then be displayed as follows (picture shows a screenshot with mouse over Greece): interactiveChordDiagram = Graphics[{innerCircle, backgroundChords, wedges, dynamicLabels}, ImageSize -> 750] ![enter image description here][7] ## Conclusions ## Eurovision-politics aside, this was an interesting exercise which I hope will be beneficial to others in the future (full notebook attached)! The visualization can greatly be improved by obtaining the vertex order which minimizes ribbon crossings and coloring the ribbons using a gradient between each node (e.g. using Polygon's VertexColors), both of which are left as an exercise for the reader :) *I found an implementation for a variant of this called [no-ribbon chord diagram][8] in 'Mathematica Data Visualization' by Nazmus Saquib, please do point me to the right direction if I missed anything else! [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=6390chord-diagram-cropped.png&userId=616023 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=6390chord-diagram-cropped.png&userId=616023 [3]: https://datavizproject.com/data-type/chord-diagram/ [4]: http://mathworld.wolfram.com/PoincareHyperbolicDisk.html [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=poincare.png&userId=616023 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=chord-diagram-static.png&userId=616023 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=5464chord-diagram-cropped.png&userId=616023 [8]: https://datavizproject.com/data-type/non-ribbon-chord-diagram/ George Varnavides 2019-07-25T00:06:49Z