https://community.wolfram.com RSS Feed for Wolfram Community showing questions tagged with Computational Humanities sorted by active. https://community.wolfram.com/groups/-/m/t/3156766 Hello! I'm a teacher of journalism at the international EDJ school in Nice FR My students have access to Mathematica 14 (but they mainly use chat-driven notebooks as the wolfram language is sort of complicated to them). Anyway. As part of the "Data Journalism" course I want to give them the assignment to read this article https://www.dailymail.co.uk/news/article-13266707/Everyone-Japan-called-Sato-year-2531-countrys-marriage-laws.html It tells the story of a Tohoku University economics professor that concluded that, given how married couples in jpn drop one of their family names in favour of both individuals taking the same one everyone will be called "SATO" by 2531. I'd like the students to perform the same simulation for their own country (after finding out the candidate family name -- for Italy that would probably be "Rossi") Now, after some digging I've found in this PDF https://think-name.jp/assets/pdf/Sato_estimation_yoshida_hiroshi.pdf the method used to perform the calculation for Japan: Handling of Past Data First, we obtained the number of people with the Sato surname in Japan from the data provided and published by "Myoji-yurai.net" (https://myoji-yurai.net/), which covers more than 99.04% of Japanese surnames. Next, we divided the number of people with the Sato surname by the total population of Japan for each year (estimated by the Ministry of Internal Affairs and Communications) * 99.04% to obtain the "ratio of the Sato surname in a given year t": x(t). From the change in the Sato surname between the latest years of 2022 and 2023, we calculated the one-year growth rate \[Rho] in the Sato surname ratio. Estimation Results (1) Growth Rate \[Rho] of the Sato Surname It is found that the ratio of the Sato surname x(t) increased from 1.480% in 2013 to 1.530% in 2023, an increase of 0.05 percentage points over more than 10 years. Calculating from the data for the most recent points of 2022 and 2023, the growth rate \[Rho] of the Sato surname ratio is (1+\[Rho]) = 1.0083. (2) Future Simulation Assuming that the ratio of the Sato surname to the Japanese population will grow at a rate of 1.0083 each year, starting from 1.530% as of March 2023, and repeating the calculation of x(t+1) = (1+\[Rho]) x(t), it was calculated that the ratio will reach 100% in approximately 500 years, in 2531. ----- **And the question is : Is anyone kind enough to write me the Wolfram Language generic code to perform the same** ? Ideally, students could get their own country basic data (if possible directly with WolfrmaLanguage functions, if not possible from outside sources) and have the system perform the simulation for them (of course, forcing the Japanese role "select one family name" even if not the case for the specific country) It is also possible that it will not converge and we will never have a "Rossi only" country not even in year 3500...or maybe yes. But that's also the point of the simulation. Thanks!! Marco Barsotti 2024-04-11T09:01:38Z https://community.wolfram.com/groups/-/m/t/3030120 I was inspired by Wolfram's blog post on [Generative AI Space and the Mental Imagery of Alien Minds][1] but realized that I can't run any of his code because my Mathematica installations are on MacOS and GPU use is not supported. Can anyone give me a sense of how long it would take to run his examples on a newish Linux or Windows laptop (minutes, hours, days)? I would like to get into the kind of experimentation he describes but I don't have a sense of whether it can be done with a modest system or whether it requires a lot of computational resources or some kind of cloud deployment. Thanks! [1]: https://writings.stephenwolfram.com/2023/07/generative-ai-space-and-the-mental-imagery-of-alien-minds/ William Turkel 2023-10-08T13:58:35Z https://community.wolfram.com/groups/-/m/t/2638404 Hi all, This Fall, I've been teaching artists and designers at the Rhode Island School of Design how to use Mathematica for creative coding and fine art making. I'll be presenting what I've seen from my students at WTC in a couple weeks and put some questions together to learn more about the arts community here and perhaps include some of your responses in my presentation. If you're willing, share your thoughts below. Thanks in advance! 1. Mathematica has a small but active visual arts community. How have you seen the usage of Mathematica as an art medium grow over time? What changes have you seen from your perspective? 2. Whether it's showing off a beautiful pattern or an attempt to capture a more complicated feeling from a unique perspective, we call both results “art”. How do you distinguish art being made in Mathematica between craft art and fine art? What does each share with the greater public? 3. What has surprised you about the ways Mathematica is being used in creative fields like art and design? 4. It doesn’t take long in the Mathematica visual arts community to learn the names of [Clayton Shonkwiler][1], [Henry Segerman][2], [Erik Mahieu][3], and [Silvia Hao][4]. What other names or projects come to mind when you think of "Mathematica + Art”? 5. Do you think the practice of art and visual creativity by scientists and mathematicians improves the visual communication standards of the STEM fields as a whole, making us all better at understanding and sharing information visually? 6. [For the Wolfram staff] There is a clear appreciation at Wolfram for aesthetics and design. You can see it in the elegance of powerful functions, in-line equation typesetting, the “Neat Examples” section in documentation, and even the promotion of Mathematica through tweetable code emphasizes patterns and visually interesting graphics. What does art or a more emotive relationship with math and science mean to Wolfram? 7. What other thoughts have these questions brought to the surface for you? [1]: https://community.wolfram.com/web/claytonshonkwiler [2]: http://www.segerman.org/ [3]: https://community.wolfram.com/web/erikmahieu [4]: https://community.wolfram.com/web/wyelen Jack Madden 2022-10-07T22:03:35Z https://community.wolfram.com/groups/-/m/t/2608592 ![enter image description here][1] After my previous previous [community contribution][2], I looked deeper into this type of illusion by further analysing existing illusions and creating exciting new ones. **1. Video as a spatio-temporal object** A video can be represented as an x-y-t space. The frames are periodic cross sections perpendicular to the t-axis. They show motion over time. To detect motion in the x- or y-direction, one needs cross sections perpendicular to the x- or y-axis. This is simple video containing 32 frames of 120 by 120 pixels with a static (blue circle) and moving (red propeller) part: aV = AnimationVideo[ Graphics[{AbsoluteThickness[10], Red, Rotate[Line[{{0, -.99}, {0, .99}}], -\[Phi]], Blue, Circle[]}, Background -> LightGray, PlotRange -> 1.2], {\[Phi], 0, 6.28, \[Pi]/16}, RasterSize -> 120]; ![enter image description here][3] Here is the same video represented as an x-y-t space. The 32 Cross sections perpendicular to the t-axis are the video frames. ![enter image description here][4] The frames are 120 by 120 pixels and the above video can also be defined by its 120 cross sections perpendicular to the x- or y-axis. Here is a function *ytSectionFromVideo* for making a cross section perpendicular to the y-axis at pixel position yf. ytSectionFromVideo[v_, yf_] := Module[{frames, count, size}, frames = VideoFrameList[v, All]; size = ImageDimensions[frames[[1]]]; count = Length[frames]; Raster[ParallelTable[ PixelValue[frames[[frm]], {x, yf}], {x, size[[1]]}, {frm, count}]]] Here are some of the y-t sections at pixel positions 35, 45 and 55 along the y-axis: ![enter image description here][5] Reversely, the function *videoFromYtSections* makes a complete set of video frames of size sz from the full set of y-t sections (one for each pixel in the y direction). videoFromYtSections[ytSections_, sz_] := Module[{xSize, ySize}, {xSize, ySize} = ImageDimensions[ytSections[[1]]]; Table[ImageRotate[ ImageReflect[ ImageResize[ Image[ParallelTable[(PixelValue[#1, {frm, xf}] &) /@ ytSections, {xf, ySize}]], {sz, sz}]], -Pi/2], {frm, xSize}]] This is a re-creation of the original video aV from its y-t sections: avFrames = videoFromYtSections[avYTs, 100]; Video[FrameListVideo[Reverse@avFrames], ImageSize -> 100] ![enter image description here][6] **2. Motion and motion illusion in videos** The y-t sections (or x-t sections) are essential to detect and create motion in videos. First we look at the completely motionless video of a landscape and 3 of its by-t sections: (landscape still.jpg", attached from "[Banff NP images][7]" landscapeV = FrameListVideo[Table[banff, 10]] ![enter image description here][8] GraphicsRow[ Graphics[ytSectionFromVideo[landscapeV, #], AspectRatio -> 1, Frame -> True, FrameLabel -> {"t", "x"}] & /@ {50, 70, 90}, ImageSize -> 600] ![enter image description here][9] Since there is no motion at all, the pixels form parallel lines to the x-axis (if we made x-t sections, lines would be parallel to the y-axis) This is a video and some of the y-t sections of the real motion in a bouncing ball video: (bouncing balls video.mp4 (attached) taken from: [depositphotos][10]" ![enter image description here][11] GraphicsRow[ Graphics[ytSectionFromVideo[landscapeV, #], AspectRatio -> 1, Frame -> True, FrameLabel -> {"t", "x"}] & /@ {50, 70, 90}, ImageSize -> 600] ![enter image description here][12] The background is static and forms parallel lines to the x-axis but the bouncing balls trace slanted or even Perpendicular lines to the x-axis. Finally, the [Mario video][13] from Jacob Yates creating the illusion of motion: fullMarioV = Video["https://jake.vision/motionillusionblog/marioReversePhi.mp4"]; ![enter image description here][14] The y-t sections of the complete video would be too crowded so, we take a cropped detail from the original: croppedMarioV = VideoFrameMap[ImageTake[#1, {228, 318}, {555, 645}] &, fullMarioV]; ![enter image description here][15] These are the 10 colors of the periodic flashes. vfl = VideoFrameList[croppedMarioV, All]; colors = ((DominantColors[#1, 2] &) /@ Take[vfl, 10])[[All, 2]] ![enter image description here][16] GraphicsRow[ Graphics[ytSectionFromVideo[croppedMarioV, #], AspectRatio -> 1, Frame -> True, FrameLabel -> {"t", "x"}] & /@ {15, 40, 50}, ImageSize -> 600] ![enter image description here][17] The y-t sections above are a mix of parallel and slanted sections parts. If we look along the time axis of these y-t sections, we notice two essential features of this illusion: **the periodic flashing** and **the slanted edges of the y-t section pattern.** In the middle, the flashing merely shows a different color each period. At the slanted edges, there is a time shift. Our brain compares the color flash of the mid section with the delayed color at the sides and will interpret it as movement. The perceived motion at the edges will appear to our eyes as to be for the whole bar and the whole frame as a set of bars. A more scientific explanation can be found in "[Spatiotemporal energy models for the perception of motion][18]" by Adelson and Bergen. **3. Making YT sections with slanted edges** A video can be re-created from its y-t sections. We want to make y-t sections with slanted edges to create the illusion of motion in a static video. The function *edgeShiftedYTsection* makes an image for an y-t section with slanted edges starting at pixel position pos and w pixels wide. The edges are d pixels wide and the number of frames per bar is frs. The total number of frames will be the number of colors in cols times frs. edgedStrip[y_, w_, h_, d_, col_] := {col, Polygon[{{d - 0.5` w, -h + y}, {-0.5` w, d - h + y}, {-0.5` w, d + h + y}, {d - 0.5` w, h + y}, {-d + 0.5` w, h + y}, {0.5` w, -d + h + y}, {0.5` w, -d - h + y}, {-d + 0.5` w, -h + y}}]} edgedStripe[pos_, w_, d_, cols_] := Translate[ MapThread[ edgedStrip[#1, w, 0.5`, d, #2] &, {Range[Length[cols]], cols}], {0.5` w + pos, 0}] edgeShiftedYTsection[pos_, w_, d_ : 3, frs_ : 6, cols_ : colors] := Module[{cls}, cls = Length[cols]; Image[ImageRotate[ Image[Graphics[ Table[Translate[edgedStripe[pos, w, d, cols], {0, y}], {y, -cls, frs cls, cls}], PlotRange -> {{0, 92}, {0, frs cls}}]], Pi/2]]] This is an example of an image to be used as an y-t section: the y-position of the edged pattern is at pixel 15 from the bottom, the total width is 65 pixels and the slanted edges are 5 pixels wide. The pattern will give flashes in 10 different colors and is repeated 6 times to create 6 video frames. ![enter image description here][19] **4. Reverse engineering Mario** We try our *edgeShiftedYTsection* function to produce y-t sections and re-create the Mario video from them. This is our home made Mario: ![enter image description here][20] **Step 1: Divide the image into horizontal bars** (16 for the Mario pic) and collect the position and width of the bars into a list. To re create the video, one needs all y-t sections but, for images like Mario, one y-t section for each of the 16 horizontal bars is sufficient. The complete set of y-t sections is then 16 times the number of frames in the resulting video. marioBarData = {{{21, 33}}, {{14, 55}}, {{14, 47}}, {{8, 67}}, {{8, 74}}, {{8, 67}}, {{21, 47}}, {{14, 40}}, {{8, 67}}, {{0, 82}}, {{0, 82}}, {{0, 82}}, {{0, 82}}, {{14, 18}, {48, 21}}, {{8, 18}, {54, 21}}, {{0, 26}, {54, 28}}}; **Step 2: Make an y-t section for each bar:** marioYTs = (ColorReplace[#1, White -> Lighter[Gray, 0.5]] &) /@ (ImageResize[#1, {60, 92}] &) /@ Apply[ImageMultiply, Apply[edgeShiftedYTsection, marioBarData, {2}], {1}]; Grid[{marioYTs}, ItemSize -> 3.5, Frame -> True]; ![enter image description here][21] **Step 3: Create the video** using the function videoFromYtSections: marioFrames = ImagePad[#, {{12, 0}, {0, 12}}, Lighter[Gray, 0.65]] & /@ videoFromYtSections[marioYTs, 100]; VideoTimeStretch[Video[FrameListVideo[marioFrames], ImageSize -> 100], 2] ![enter image description here][22] **5. Creating completely new illusions: bunny** Here is a bunny extracted from: [Clip-art library][23] rasterized and converted to 34 horizontal bars: ![enter image description here][24] This is a list of positions and widths in pixels of the 34 bars and their respective y-t sections: bunnyBarData = {{{26, 6}, {38, 3}}, {{26, 6}, {35, 6}}, {{23, 9}, {35, 9}}, {{23, 21}}, {{20, 24}}, {{20, 24}}, {{20, 24}}, {{23, 18}}, {{20, 21}}, {{17, 21}}, {{14, 24}}, {{11, 27}, {50, 12}}, {{8, 60}}, {{8, 66}}, {{8, 69}}, {{5, 75}}, {{2, 81}}, {{2, 81}}, {{5, 81}}, {{14, 72}}, {{14, 72}}, {{14, 72}}, {{17, 72}}, {{17, 72}}, {{20, 69}}, {{26, 63}}, {{29, 60}}, {{29, 63}}, {{29, 63}}, {{29, 60}}, {{26, 54}}, {{17, 24}, {47, 27}}, {{23, 12}, {44, 21}}, {{44, 9}}}; bunnyYTs = (ImageReflect[#1, Left] &) /@ (ImageResize[#1, 60] &) /@ (ColorReplace[#1, White -> Lighter[Gray, 0.65]] &) /@ Apply[ImageMultiply, Map[edgeShiftedYTsection[Sequence @@ #1, 3, 6, colors] &, bunnyBarData, {2}], {1}]; Some of the 34 y-t sections (at bars nos 10, 20 and 32 ): GraphicsRow[ Graphics[bunnyYTs[[#]], AspectRatio -> 1, Frame -> True, FrameLabel -> {"t", "x"}] & /@ {10, 20, 32}, ImageSize -> 600] ![enter image description here][25] The video frames and the resulting video are derived from the y-t sections: bunnyFrames = Map[ImageResize[#, {95, 112}] &, ImagePad[#, {{12, 0}, {0, 12}}, Lighter[Gray, 0.65]] & /@ videoFromYtSections[bunnyYTs, 100]]; bunnyFrames[[;; 5]] ![enter image description here][26] Video[FrameListVideo[ ImagePad[#, {{12, 0}, {0, 6}}, Lighter[Gray, 0.65]] & /@ Flatten@Table[ImageReflect[#, Left] & /@ bunnyFrames, 10]], ImageSize -> 275] ![enter image description here][27] **8. Creating completely new illusions: rooster** Here is a rooster image extracted from: Clip-art library rasterized and converted to 43 horizontal bars: ![enter image description here][28] roosterBarData = {{{13, 6}}, {{9, 14}}, {{7, 18}, {63, 10}}, {{5, 22}, {63, 12}}, {{3, 26}, {61, 16}}, {{3, 28}, {65, 10}}, {{1, 30}, {63, 14}}, {{1, 32}, {61, 18}}, {{1, 2}, {5, 28}, {61, 18}}, {{5, 28}, {59, 18}}, {{3, 32}, {59, 18}}, {{3, 34}, {59, 18}}, {{7, 30}, {57, 22}}, {{7, 30}, {57, 22}}, {{7, 32}, {55, 24}}, {{7, 32}, {49, 32}}, {{7, 32}, {47, 34}}, {{9, 32}, {45, 36}}, {{9, 8}, {19, 62}}, {{9, 8}, {19, 60}}, {{19, 60}}, {{21, 56}}, {{21, 6}, {29, 46}}, {{21, 2}, {25, 2}, {29, 46}}, {{29, 44}}, {{27, 44}}, {{27, 42}}, {{27, 38}}, {{27, 36}}, {{29, 34}}, {{39, 22}}, {{41, 18}}, {{43, 14}}, {{45, 10}}, {{45, 8}}, {{45, 18}}, {{45, 2}, {57, 10}}, {{45, 2}, {59, 10}}, {{45, 2}, {67, 2}}, {{43, 4}, {67, 2}}, {{43, 4}}, {{43, 4}}, {{45, 4}}}; Sample YT sections at bars nos 10, 20 and 32 out of 43: roosterYTs = (ImageResize[#1, 60] &) /@ Apply[ImageMultiply, Apply[edgeShiftedYTsection, roosterBarData, {2}], {1}]; GraphicsRow[ Graphics[roosterYTs[[#]], AspectRatio -> 1, Frame -> True, FrameLabel -> {"t", "x"}] & /@ {10, 20, 32}, ImageSize -> 600] ![enter image description here][29] The video frames and video as derived from the y-t sections: ![enter image description here][30] roosterV = Video[FrameListVideo[ ImagePad[#, {{12, 0}, {0, 6}}, Lighter[Gray, 0.65]] & /@ Flatten@Table[ImageReflect[#, Left] & /@ roosterFrames, 10]], ImageSize -> 275] ![enter image description here][31] Several of the illusions can be combined into new ones. The possibilities are endless. Here is the code for the "rooster and hens" video at the top: ![enter image description here][32] I hope this helps you making your own visual illusions! [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=schoolOfHens15.gif&userId=68637 [2]: https://community.wolfram.com/groups/-/m/t/2567382 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=avvideo.gif&userId=68637 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=xytspace.png&userId=68637 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8414ytsfromav.png&userId=68637 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=5413avfromyts.gif&userId=68637 [7]: https://www.gildshire.com/national-parks-in-the-usa-that-you-should-visit-part-one/ [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=landcscapevideo.gif&userId=68637 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ytsfromlandscape.png&userId=68637 [10]: https://depositphotos.com/stock-footage/bouncing-balls.html?offset=240 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=bouncingballssmall.gif&userId=68637 [12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ytsfrombouncingballs.png&userId=68637 [13]: https://jake.vision/motionillusionblog/marioReversePhi.mp4 [14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=fullMarioV.gif&userId=68637 [15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=croppedMarioColor.gif&userId=68637 [16]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4806colors.png&userId=68637 [17]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ytsfromcroppedMario.png&userId=68637 [18]: http://persci.mit.edu/pub_pdfs/spatio85.pdf [19]: https://community.wolfram.com//c/portal/getImageAttachment?filename=5328edgeshiftedytsection.png&userId=68637 [20]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9087mariopic16bars.png&userId=68637 [21]: https://community.wolfram.com//c/portal/getImageAttachment?filename=mario16yts.png&userId=68637 [22]: https://community.wolfram.com//c/portal/getImageAttachment?filename=reverseEngineeredMariobest.gif&userId=68637 [23]: http://clipart-library.com/animal-silhouettes-images.html [24]: https://community.wolfram.com//c/portal/getImageAttachment?filename=bunnyandrsater.png&userId=68637 [25]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ytsfrombunny.png&userId=68637 [26]: https://community.wolfram.com//c/portal/getImageAttachment?filename=bunnyframes.png&userId=68637 [27]: https://community.wolfram.com//c/portal/getImageAttachment?filename=bunnyVbest.gif&userId=68637 [28]: https://community.wolfram.com//c/portal/getImageAttachment?filename=roosterandraster.png&userId=68637 [29]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ytsfromrooster.png&userId=68637 [30]: https://community.wolfram.com//c/portal/getImageAttachment?filename=roosterframes.png&userId=68637 [31]: https://community.wolfram.com//c/portal/getImageAttachment?filename=roosterV25.gif&userId=68637 [32]: https://community.wolfram.com//c/portal/getImageAttachment?filename=hensAndRooster.gif&userId=68637 Erik Mahieu 2022-08-31T12:39:44Z https://community.wolfram.com/groups/-/m/t/2452694 I am working on developing a tool in Wolfram Language to correlate user ratings on the website Board Game Geek (BGG, [www.boardgamegeek.com][1]). Users on the site can rate games with a value from 1-10, and my initial goal is to allow someone to check their ratings against those of other users to find other users whose tastes generally match their own. Part of this involves, of course, grabbing all of a user's rated games. BGG has an API which allows this. To access it, one does this: userName = "skutsch"; urlUser = "https://www.boardgamegeek.com/xmlapi2/collection?username=" <> userName <> "&rated=1"; r1 = Import[urlUser, "XML"]; When that call is made, BGG checks if a data file already exists for that user. If so, it serves the data as XML. If not, it sends an HTTP code of 202 and returns a message that it is preparing the data. Accessing the link again a few seconds later usually then results in an HTTP code of 200 and the XML data. (The data is saved by BGG until either the user makes changes to their collection or a number of days pass by. I've been hitting these users as test cases so they will probably serve data on the first try.) When it comes to the XML results, I am clueless. I've read the documentation for XML in WL and haven't been able to digest it. The data *very roughly* looks like this: <items totalitems="318" ... > <item objecttype="thing" objectid="177590" subtype="boardgame"...> <name ...> <blah> <blah> <stats ...> <rating value="7.5"> <blah/> <blah/> </rating> </stats> <blah> </item> <item objecttype="thing" objectid="68448" subtype="boardgame"...> <name ...> <blah> <blah> <stats ...> <rating value="6.5"> <blah/> <blah/> </rating> </stats> <blah> </item> <...many more items...> </items> As I have editorially indicated, I'm only interested in a few values here. What I want to parse out is: - for every <item> where <item subtype="boardgame">: - get <item objectid="xxxxx"> - get <rating value="yy"> I was trying to do this in a very brute force matter thusly: a = <|"gameID" -> Values[r1[[2, 3, i, 2, 2]]], "userName" -> username, "rating" -> ToExpression @@ Values[r1[[2, 3, i, 3, 5, 3, 1, 2]]]|> basically going to the exact location of the data and iterating through it (i = 1 to <items totalitems="i">). Not great, but seemed to work. I'm lazy, so I liked that it kept me from having to figure out the XML. Unfortunately there's a snag. If you look at the data where userName="Legomancer", you hit a problem at item 129 (<item objectid="1231">). That item has an additional element that others don't have: <item objecttype="thing" objectid="1231" subtype="boardgame" collid="6163073"> <name sortindex="1">Bandu</name> <originalname>Bausack</originalname> <yearpublished>1987</yearpublished> That **<originalname>** element shifts the rest of the fields, wrecking my brainless strategy and throwing an error. So I guess I need to learn how to use XML after all. So while I read up again on XML and knock at it with some trial and error, if anyone could point me towards a path, that would be super helpful. [1]: http://www.boardgamegeek.com Dave Lartigue 2022-01-22T15:26:26Z https://community.wolfram.com/groups/-/m/t/520009 Hi, I was wondering how a 3D version of WordCloud could be made : WordCloud[EntityValue[CountryData[],{"Name","Population"}]] nfaterpe 2015-06-28T23:31:56Z https://community.wolfram.com/groups/-/m/t/1862900 Hi, are there any plans underway to add support for [StyleGAN][1] / [StyleGAN2][2] in the Wolfram Neural Repository? I've just started playing around with generating my own images with [RunwayML][3] by re-using an existing community StyleGAN model (it sure helps that they start you off w/$100 Cloud GPU credits) but I'd really like to keep learning and doing this further on the Wolfram platform. Best, Arno [1]: https://github.com/NVlabs/stylegan [2]: https://github.com/NVlabs/stylegan2 [3]: https://runwayml.com Arno Bosse 2020-01-19T09:52:14Z https://community.wolfram.com/groups/-/m/t/2103451 Hi, I just joined the Wolfram community and was trying out Mathematica for mapping and research purposes. I came across a very help guide to making historical animated maps, however I am encountering issues when I try to implement it. I'm pasting the code below and as I am a beginner, any help would be appreciated. I really want to benefit and enjoy from this platform. Thanks, Shahmir shahmir nawaz 2020-10-28T07:54:37Z https://community.wolfram.com/groups/-/m/t/1900563 I am looking through the documentation on V 12 for a way to label vertices, edges, and faces on polyhedra. (In specific I am trying to make tetrahedra that look like this.) How do I make this happen? ![enter image description here][1] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=IMG_7435.jpeg&userId=1518292 Kathryn Cramer 2020-03-18T06:57:17Z https://community.wolfram.com/groups/-/m/t/1757394 I want to write a 'Gauss' function in my main program like the way its written in Matlab. In the following example I want to pass the variables ('aar' & 'es' are matrices and other are scalars) "aar, es, x1value, x2value, x3value, x4value, y1value, y2value, y3value, y4value" like given below. I want the output to store in detjacobs & Invdetjacobs. Kindly suggest me the correct way. [detjacobs, Invdetjacobs] = Gauss[aar, es, x1value, x2value, x3value, x4value, y1value, y2value, y3value, y4value] Do[ Do[ r = aar[[i]]; s = es[[j]]; shape1 = ((1. - r) (1. - s))/4.; shape2 = ((1. + r) (1. - s))/4.; shape3 = ((1. + r) (1. + s))/4.; shape4 = ((1. - r) (1. + s))/4.; dhdr1 = 1./4. (-1. + s); dhdr2 = (1. - s)/4.; dhdr3 = 1./4. (1. + s); dhdr4 = -(1. + s)/4.; dhds1 = 1./4. (-1. + r); dhds2 = 1./4. (-1. - r); dhds3 = (1. + r)/4.; dhds4 = (1. - r)/4.; detjacobs = {{dhdr1 x1value + dhdr2 x2value + dhdr3 x3value + dhdr4 x4value, dhdr1 y1value + dhdr2 y2value + dhdr3 y3value + dhdr4 y4value}, {dhds1 x1value + dhds2 x2value + dhds3 x3value + dhds4 x4value, dhds1 y1value + dhds2 y2value + dhds3 y3value + dhds4 y4value}}; Invdetjacobs = 1/detjacobs; ,{j,1,4}]; ,{i,1,4}]; khaja moinuddin mohammed 2019-08-09T11:59:47Z https://community.wolfram.com/groups/-/m/t/1383246 ## Introduction ## Hello Wolfram community! My name is Ryan Heo and I am a student at the Wolfram high school summer camp where over the past two weeks I was able to work on and complete a project called "Voice Sentiment classification". The goal of this project was to be able to take an input of an audio speech file and be able to classify that into one of the 8 different categories of emotion using machine learning. Down below is are the steps and the procedure I followed in the completion of my project. ##Dataset## For this project I used the Ryerson Audio-Visual Database of Emotional Speech which consisted of varying tones or emotion of speech recordings from voice actors.Down below is the importation of the speech audio files that I have downloaded folders = Select[FileNames["*", NotebookDirectory[]], DirectoryQ[#] && StringContainsQ[#, "Actor"] &]; fileNames = FileNames["*.wav", #] & /@ folders // Flatten; audio = Import /@ fileNames; ## Encoding the data ## After I have imported all the data files I took extracted the number section of the file name that matches the different emotion categories. I then separated these numbers into eight sections which corresponded with the emotional category of these files. Additionally, I threaded these sections to their corresponding emotion and after flattening the list and random sampling the data I inserted the data into the net encoder. I converted the data into a mel-frequency cepstrum which is based on the log power spectrum and does a better job modeling the human auditory system than the a normal cepstrum. In the net encoder I set my sampling rate and the number of filters I had to a high number in order to create more data points and to be able to extract more features respectively. enc = NetEncoder[{"AudioMelSpectrogram", "WindowSize" -> 4096, "Offset" -> 1024, "SampleRate" -> 44100, "MinimumFrequency" -> 1, "MaximumFrequency" -> 22050, "NumberOfFilters" -> 128}] ; After encoding the data I separated it into sections consisting of length 41 and reshaped the array to be inputted into neural net for training. Down below is a representation of the mel spectrogram represented by a matrix plot ![enter image description here][1] ##Neural Networks ## I used a combination of a convolutional neural network and a recurrent network for classification. Down below is the convolutional neural network architecture that I used convNet = NetChain[ { conv[32], conv[32], PoolingLayer[{3, 3}, "Stride" -> 3, "Function" -> Max], BatchNormalizationLayer[], Ramp, conv[64], conv[64], PoolingLayer[{3, 3}, "Stride" -> 3, "Function" -> Max], BatchNormalizationLayer[], Ramp, conv[128], conv[128], PoolingLayer[{3, 3}, "Stride" -> 3, "Function" -> Max], BatchNormalizationLayer[], Ramp, conv[256], conv[256], PoolingLayer[{3, 3}, "Stride" -> 3, "Function" -> Max], BatchNormalizationLayer[], Ramp, LinearLayer[1024], Ramp, DropoutLayer[0.5], LinearLayer[8], SoftmaxLayer[] }, "Input" -> {1, 41, 128}, "Output" -> NetDecoder[{"Class", newClasses}] ] This is the architecture for the recurrent network with LSTM layers recurrentNet = NetChain[{ LongShortTermMemoryLayer[128, "Dropout" -> 0.3], LongShortTermMemoryLayer[128, "Dropout" -> 0.3], SequenceLastLayer[], LinearLayer[Length@newClasses], SoftmaxLayer[] }, "Input" -> {"Varying", 8}, "Output" -> NetDecoder[{"Class", newClasses}] ] I then combined these two nets netCombined = NetChain[{ NetMapOperator[cnnTrainedNet], lstmTrained }] I inputted the section of the dataset files I reserved for testing and validation and inputted these files into the combined neural net achieving an accuracy of 85 percent.Down below would be a good representation of how accurate my net was in in classifying these files into their respective emotional categories. For example in the neutral category out of the 38 samples of the randomly distributed data it was able to correctly match these files into neutral 28 times. As shown below the net seems to confuse the neutral emotion with the sadness emotion as seen by guessing sad 4 times out of 38 files. ![enter image description here][2] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Spectrogram.jpg&userId=1372518 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ConfusionMatrixPlot.jpg&userId=1372518 ## Deploying the Microsite ## MicroFunc[aud_Audio] := Module[{net, enc}, net = Import[CloudObject[ "https://www.wolframcloud.com/objects/ryanheo2001/CombinedNet.\ wlNet"], "WLNET"]; enc = NetEncoder[{"AudioMelSpectrogram", "WindowSize" -> 4096, "Offset" -> 1024, "SampleRate" -> 44100, "MinimumFrequency" -> 1, "MaximumFrequency" -> 22050, "NumberOfFilters" -> 128}]; net[Transpose[{Partition[enc[aud], 41]}, {2, 1, 3, 4}]] ] CloudDeploy[ FormPage[{"Audio" -> "CachedFile" -> "", "URL" -> "URL" -> ""}, Which[ #Audio =!= "", MicroFunc[Audio[#Audio]], #URL =!= "", MicroFunc[Import[#URL, "Audio"]], True, ""] &, PageTheme -> "Red", AppearanceRules -> <|"Title" -> "Voice Sentiment Classifier"|>], "VoiceSentiment", Permissions -> "Public"] The final microsite can be found here at: https://www.wolframcloud.com/objects/ryanheo2001/VoiceSentiment Lastly, I want to thank my mentor Michael and all the instructors and staff at the wolfram summer camp. They have been very helpful and I have learned valuable lessons from them these past two weeks. Ryan Heo 2018-07-13T20:57:43Z https://community.wolfram.com/groups/-/m/t/1382958 # Economics of Cryptokitties ![enter image description here][1] ## Executive Summary Cryptokitties is an online game run on the Ethereum blockchain that sells virtual cats with different "cattributes" (cat attributes). The goal of this project is to analyze what factors affect the price of a cryptokitty. The results from the gathered data show that certain cattributes can affect the price of a cryptokitty, but the scarcity of that cattribute does not seem to play a factor in determining a cryptokitty's price. The time a kitty was sold can be a contributor to the price of a cryptokitty, with cryptokitties that were sold soon after the game's launch tending to have higher prices than kitties sold at later times. Also, a kitty is most likely to be sold within the first two weeks of its birth. ##Introduction ### What are Cryptokitties? Cryptokitties are virtual cats sold online using the Ethereum blockchain. Each cryptokitty has a certain set of cattributes, which is determined by their online genetic code. One cryptokitty is released every 15 minutes by the owners of Cryptokitties. While cryptokitties may be released by the company, cryptokitties can also breed, mixing up their genetic code and be creating new kitties that share cattributes passed down from its parents, and possibly even have a mutation that creates a new cattribute. When a person buys a cryptokitty online they own the rights to the genetic code of the cryptokitty, but the company owns the rights to all the images of the cryptokitty and all the programming that went into creating the virtual cat. One can buy a cryptokitty by visiting the Cryptokitties website and having an Ethereum wallet and buy a cryptokitty using ether, the Ethereum cryptocurrency. ###Why should I care? Blockchain technology will be an up-and-coming innovation that will change the way that people do online transactions. Blockchain technology is not just limited to the use of currency but can be applied to many different online fields, such as for games like Cryptokitties. Analyzing the economics Cryptokitties can help predict what a new wave of Blockchain games will look and operate like. ##Gathering the data To gather the data, I accessed the CryptoKittyDex website[1] and shifted between kitties by changing the cryptokitty's index number which is the last number in the URL. ImportCryptoKittiesDB["Web", range_] := importRawKittiesData /@ (Range @@ range) ImportCryptoKittiesDB["File", filepath_] := Import[filepath]; importRawKittiesData[id_] := Block[{request = HTTPRequest[ URLBuild[{"https://cryptokittydex.com/kitties/", ToString[id]}]], result}, result = URLRead[request]; If[result["StatusCode"] == 200, Import[result, "Data"]] ] An obstacle I faced while doing this is that if I try to mass import cryptokitties, after some number of kitties there would be an error in importing data from a webpage, causing any importation after the failed import to never happen. To combat this problem I imported all kitties in random sets of eleven consecutive kitties and then pause for a few seconds before importing another set of kitties. This allowed for a break in the importation making new sets not crash due to and importation failure in an earlier set of kitties. I would flatten the gathered data so it'd be usable later, and then saved the data in a file in the case of my kernel crashing. ranges = Table[With[{n = RandomInteger[825000]}, {n, n + 10}], 10]; sample72 = With[{range = #}, Pause[5]; ImportCryptoKittiesDB["Web", range] ] & /@ ranges; cryptokittiesSample72 = Flatten[sample72, 1]; Save["/Users/kylekotanchek/Documents/CryptokittiesDatabases/\ CryptokittiesSample72.wl", cryptokittiesSample72] Once a enough sets of data were gathered, I put them all into a database after deleting duplicates and any cases of failed imports which occurred in the form of Null. database = DeleteCases[ DeleteDuplicates[ Join[cryptokittiesSample1, cryptokittiesSample2, cryptokittiesSample3, cryptokittiesSample[40], cryptokittiesSample41, cryptokittiesSample42, cryptokittiesSample43, cryptokittiesSample44, cryptokittiesSample45, cryptokittiesSample46, cryptokittiesSample47, cryptokittiesSample48, cryptokittiesSample49, cryptokittiesSample50, cryptokittiesSample51, cryptokittiesSample52, cryptokittiesSample53, cryptokittiesSample54, cryptokittiesSample55, cryptokittiesSample56, cryptokittiesSample57, cryptokittiesSample58, cryptokittiesSample59, cryptokittiesSample60, cryptokittiesSample61, cryptokittiesSample62, cryptokittiesSample63, cryptokittiesSample64, cryptokittiesSample65, cryptokittiesSample66, cryptokittiesSample67, cryptokittiesSample68, cryptokittiesSample69, cryptokittiesSample70, cryptokittiesSample71, cryptokittiesSample72]], Null]; ##Compiling the data Once all the data was together, I was able to take certain parts of all of the data of the individual kitties and compile it in a usable way. I found the time a kitty was born, the generation of the kitty, the cattributes of the kitty, and the price and time the kitty was sold. A struggle found was that a kitty could have never been sold, sold once, or sold multiple times. Originally I ignored the cryptokitties that had never been sold, but later changed it to making their price zero after realizing this was causing price inflation in determining the average cost of a cryptokitty. Since every cat needed a time that it was sold at, I made cats that were never sold to have a selling data in 2016, which was before Cryptokitties was launched, so that it'd have no effect in analyzing the time vs. price distribution of sold cats. For every cryptokitty I paired the mean of all the prices a kitty was sold and paired that with each of its cattributes. I also made a function to see the average price value of a cattribute by taking the mean of all the prices of the cryptokitties that have the same cattribute. I dropped the last 15 items in the variable MeanCattributePrice because of some random kitties that never had their cattributes appear on the CryptoKittyDex website. getPriceInfo[rawdata_] := Block[{data = Cases[rawdata, {x_String, _} /; ! StringFreeQ[x, "Sold for"], \[Infinity]], rawprices, rawdates, prices, dates}, rawprices = data[[All, 1]]; rawdates = data[[All, 2]]; prices = Quantity[ ToExpression@ First[StringCases[#, RegularExpression["Sold for ([[:print:]]+) ETH"] -> "$1"]], "Ethers"] & /@ rawprices; dates = DateObject /@ rawdates; MapThread[List, {prices, dates}]] GetKittyData[database_, id_Integer] := Catch[Block [{KittyData, KittySoldPrice, KittyBorn, KittyGeneration, Cattributes, priceInfo}, (*832250 kitties*) KittyData = database[[id, 2]]; priceInfo = getPriceInfo[KittyData]; If[priceInfo === {}, <| KittyBorn -> DateObject@ StringDrop[ StringReplace[KittyData[[1, 2]], "Born: " :> ""], -4], KittyGeneration -> StringReplace[KittyData[[1, 3]], "Generation: " :> ""], Cattributes -> StringSplit[ StringReplace[ StringReplace[KittyData[[1, 7]], "Cattributes: " :> ""], " " :> ""], " , "], KittySoldPrice -> {Quantity[0.0, "Ethers"], DateObject[{2016, 1, 1}]} |>, <| KittyBorn -> DateObject@ StringDrop[ StringReplace[KittyData[[1, 2]], "Born: " :> ""], -4], KittyGeneration -> StringReplace[KittyData[[1, 3]], "Generation: " :> ""], Cattributes -> StringSplit[ StringReplace[ StringReplace[KittyData[[1, 7]], "Cattributes: " :> ""], " " :> ""], " , "], KittySoldPrice -> priceInfo |> ] ] ] CattributePricePK[database_, x_Integer] := Block[{list, price, kittydata = GetKittyData[database, x]}, If[Lookup[kittydata, KittySoldPrice] === {Quantity[0.`, "Ethers"], DateObject[{2016, 1, 1}, "Day", "Gregorian", -4.`]}, {#, Quantity[0.`, "Ethers"]} & /@ First[StringSplit[Lookup[kittydata, Cattributes], ","]], list = StringSplit[First[kittydata[[3]]], ","]; If[Length[ kittydata[[4]]] == 1, price = kittydata[[4, 1, 1]], price = Mean[ Table[kittydata[[4, n]], {n, Length[kittydata[[4, 1]]]}][[All, 1]]]]; Table[{n, price}, {n, If[Length[ kittydata[[4]]] == 1, StringSplit[First[kittydata[[3]]], ","], list]}] ] ] CryptoKittiesData[database_, id_, "FullInfo"] := GetKittyData[database, id] CryptoKittiesData[database_, id_, "CattributesPrice"] := CattributePricePK[database, id] CryptoKittiesData[database_, "CattributesMeanPrice"] := Block[{cattributesSet, cleandb = DeleteCases[database, Null], dblength}, dblength = Length[cleandb]; cattributesSet = Flatten[CryptoKittiesData[cleandb, #, "CattributesPrice"] & /@ Range[dblength], 1]; Mean[#[[All, 2]]] & /@ GroupBy[cattributesSet, First] ] MeanCattributesPrice = CryptoKittiesData[database, "CattributesMeanPrice"][[1 ;; -15]]; ##Finding Patterns The first pattern I wanted to find was to see was if the scarcity of a cattribute is what determines the average value of the cattribute or if the scarcity of the cattribute isn't related to the cattribute's price. Due to some string importation errors in cattributes while compiling the cattribute-price relations, I had to find the cattributes that appeared in both the cattribute-price relations and in the cattribute-scarcity relation. Once I did that I then applied that intersection list to the cattribute-price and cattribute-scarcity relations to get two other lists that contained all of the cattributes shared between the two original lists. completeCryptokittiesZeroSampleCounts = Counts[Sort[ Flatten[Table[ Table[StringSplit[ StringSplit[ StringReplace[ StringReplace[database[[y, 2, 1]], "Cattributes: " :> ""], " " :> ""], " , "][[7, 1]], ","][[x]], {x, Length[StringSplit[ StringSplit[StringReplace[StringReplace[database[[y , 2, 1]], "Cattributes: " :> ""], " " :> ""], " , "][[7, 1]], ","]]}], {y, Length[database]}], 1]]][[15 ;; 198]] listofSampleZeroCounts = Table[{Keys[database][[x]], Values[database][[x]]}, {x, Length[database]}] listofSampleZeroMeanPrices = Table[{Keys[MeanCattributesPrice][[x]], Values[ MeanCattributesPrice][[x]]}, {x, Length[MeanCattributesPrice]}] intersectionofLists = Intersection[listofSampleZeroCounts[[All, 1]], listofSampleZeroMeanPrices[[All, 1]]] intersectionofSampleZeroMeanPrices = SortBy[Flatten[ Table[If[MatchQ[yay[[1]], nay], yay, Nothing], {yay, listofSampleZeroMeanPrices}, {nay, intersectionofLists}], 1], First] intersectionofSampleZeroCounts = Flatten[Table[ If[MatchQ[yay[[1]], nay], yay, Nothing], {yay, listofSampleZeroCounts}, {nay, intersectionofLists}], 1] Then I graphed the two resulting list by sorting all the cattributes in alphabetical order and placing it on the x-axis. For the first graph I showed the price in ethers on the y-axis, and in the second graph I showed how common each cattribute was on the y-axis. BarChart[Transpose[intersectionofSampleZeroMeanPrices][[2]], ChartLabels -> Automatic] ![Mean Cattribute Price in Ethers][2] BarChart[Transpose[intersectionofSampleZeroCounts][[2]]] ![How many times each cattribute appears][3] My hypothesis assumed that the two graphs would show an inverse relationship and that the price of a cattribute would originate from its scarcity, however the graphs showed no patterns between the two, proving my hypothesis to be wrong and proving there is no relationship between the scarcity of a cattribute and the cattribute's price. We can also see Benford's Law apply to the first digit of the prices of the cryptokitties that were sold. allPrices = Flatten[Table[ If[getPriceInfo[database[[n]]] == {}, Nothing, getPriceInfo[database[[n]]]], {n, Length[database]}], 1][[All, 1, 1]]; Histogram[ First@First[RealDigits[FractionalPart[#]*10]] & /@ allPrices] ![Beford's Law in Cryptokitties prices][4] We can also see the price of cryptokitties sold over time. In the graph, we can see that cryptokitties sold soon after the game's release in November 28, 2017 to about January 2018 tended to be sold for higher prices than kitties sold in times after that period. sortedDatesSold = SortBy[Flatten[ Table[If[getPriceInfo[database[[n]]] == {}, Nothing, getPriceInfo[database[[n]]]], {n, Length[database]}], 1], Last] DateListPlot[ Thread[{sortedDatesSold[[All, 2]], sortedDatesSold[[All, 1]]}]] ![Price of cryptokitties sold over time][5] Here is a microsite for looking up a cattribute and seeing what it's average price is and how common it is among kitties. [Link to Finding a Cattribute's Price and Commonality][6] Some more information was found by Christian Pasquel using the same data and analyzing the time difference between when a kitty was born and sold. The variable data is the same thing as database, which was a variable used earlier. data = Import[ FileNameJoin[{NotebookDirectory[], "cryptokittiesData01.wl"}]]; He then deleted all the kitties that had never been sold before and found the difference between the time that the kitty was born and the kitty was sold. The mean time of the difference of a kitty being born and sold was almost nine days, with many kitties being sold the same day they're born and some taking half a year to be sold since their birth; the longest difference in our dataset was 164 days. The histogram below shows the distribution of differences of cats being sold since being born. In[170]:= soldCryptokitties = DeleteCases[ data, <|__, KittySoldPrice -> {Quantity[0.`, "Ethers"], DateObject[{2016, 1, 1}, "Day", "Gregorian", -4.`]}|>]; Computing the time they stayed with her owners In[171]:= timeBeforeLeaving = Function[ck, (First[Sort[#[[2]][[All, 2]]]] - #[[1]]) &@ Lookup[ck, {KittyBorn, KittySoldPrice}]] /@ soldCryptokitties; MinMax values In[172]:= N@UnitConvert[MinMax[timeBeforeLeaving], "Days"] Out[172]= {Quantity[0., "Days"], Quantity[164.849, "Days"]} Mean time In[173]:= UnitConvert[Mean[timeBeforeLeaving] // N, "Days"] Out[173]= Quantity[8.93256, "Days"] Histogram (in days) In[174]:= Histogram[UnitConvert[timeBeforeLeaving, "Days"]] ![Cryptokitty born-sold distribution][7] And Benford's Law still applies to the born-sold distribution. Histogram[First[IntegerDigits[#[[1]]]] & /@ timeBeforeLeaving] ![Benford's Law applied to cryptokitty born-sold distribution][8] ##Future Work Gathering more data into the dataset will be beneficial. Currently, there are only 3,112 cryptokitties inside the database, which are trying to represent over 840,000 kitties. Also looking more deeply into the relationships different traits that cryptokitties have will show more complex patterns. Some of these traits include whether the kitty has parents or not, what generation it is, the genetic code of the kitty, the kitty's description, and more. ## Reference and other lists - [Cattribute Details][9] - [Cryptokitty Indexes][10] - [Cryptokitties Website][11] - [Hackernoon Cryptokitties Explanations][12] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=cryptokitties-ethereum-game.png&userId=1371793 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=GraphMeanPricesofCattributes.png&userId=1371793 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Scarcityof.png&userId=1371793 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=HistogramofCryptokittiesBenford%27sLaw.png&userId=1371793 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Cryptokittypricesovertime.png&userId=1371793 [6]: Hyperlink%5B%22https://www.wolframcloud.com/objects/d5d2d294-ef02-4053-%5C%20a0ac-9c72253d6c6a%22,%20%5C%20%22https://www.wolframcloud.com/objects/d5d2d294-ef02-4053-a0ac-%5C%209c72253d6c6a%22%5D [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Cryptokittybornsolddistribution.png&userId=1371793 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=BenfordsLawborn-solddistribution.png&userId=1371793 [9]: https://cryptokittydex.com/ [10]: https://cryptokittydex.com/kitties/527438 [11]: https://www.cryptokitties.co [12]: https://hackernoon.com/hacking-the-cryptokitties-genome-1cb3e7dddab3 Kyle Kotanchek 2018-07-13T19:48:35Z https://community.wolfram.com/groups/-/m/t/1256480 The Wolfram Community is now ~4.5 years 'old'. So time to do some analysis… let's go! Let's download all the threads-titles, their votes, their authors et cetera: SetDirectory[NotebookDirectory[]]; $HistoryLength=1; xml=Import["http://community.wolfram.com/dashboard/-/discussions-list/all+groups/Any+discussions/none/active/full/10000/1/filter","XMLObject"]; Export["website.mx",xml] This will save that output to `website.mx` file next to your notebook. Here is a small function that extract the relevant data: ClearAll[GetThreadProperties] GetThreadProperties[threadxml_]:=Module[{url,title,creator,creatorurl,views,replies,votes}, {url,title}=FirstCase[threadxml,XMLElement["h3",{"class"->"asset-title"},{_,XMLElement["a",{"shape"->"rect","href"->url_},{title_}],_}]:>{url,title},{Missing[],Missing[]},\[Infinity]]; {creator,creatorurl}=FirstCase[threadxml,XMLElement["span",{"class"->"metadata-entry"},{_,XMLElement["span",{"class"->"asset-meta-bold"},{"CREATED BY: "}],_,XMLElement["span",{"class"->"asset-meta-normal"},{_,XMLElement["a",{"shape"->"rect","href"->creatorprofileurl_},{creator_}],_}],_}]:>{creator,creatorprofileurl},{Missing[],Missing[]},\[Infinity]]; views=FirstCase[threadxml,XMLElement["div",{"class"->"views stats"},{_,XMLElement["div",{"class"->_},{views_}],_,XMLElement["div",{"class"->_},{"VIEWS"}],_}]:>views,Missing[],\[Infinity]]; replies=FirstCase[threadxml,XMLElement["div",{"class"->"replies stats"},{_,XMLElement["div",{"class"->_},{replies_}],_,XMLElement["div",{"class"->_},{"REPLIES"}],_}]:>replies,Missing[],\[Infinity]]; votes=FirstCase[threadxml,XMLElement["div",{"class"->"votes stats"},{_,XMLElement["div",{"class"->_},{votes_}],_,XMLElement["div",{"class"->_},{"VOTES"}],_}]:>votes,Missing[],\[Infinity]]; views=If[StringEndsQ[views,"K"],1000ToExpression[StringDrop[views,-1]],ToExpression@views]; replies=If[StringEndsQ[replies,"K"],1000ToExpression[StringDrop[replies,-1]],ToExpression@replies]; votes=If[StringEndsQ[votes,"K"],1000ToExpression[StringDrop[votes,-1]],ToExpression@votes]; <|"url"->url,"title"->title,"creator"->creator,"views"->views,"replies"->replies,"votes"->votes,"createrurl"->creatorurl|> ] Import the data from the mx file, and then get the relevant values from it using the above function, store in a dataset: tmp=Import["website.mx"]; tmp=Cases[tmp,XMLElement["div",{"class"->"asset-abstract default-asset-publisher","style"->_},___],\[Infinity]]; ds=Dataset[GetThreadProperties/@tmp]; Here an example: ![enter image description here][1] Let's start simple and get the number of threads, the number of views, votes, and replies: Length[ds] ds[Total,{"views","votes","replies"}] ![enter image description here][2] Nearly 8000 topics and nearing 15 mega-views! Let's check the number of replies for each topic: ListLogPlot[Tally[Normal[ds[All, "replies"]]], AxesLabel -> {"Number of replies", "Number of threads"}] giving: ![enter image description here][3] We can also plot the number of votes vs rank: ListLogLogPlot[Flatten[Normal[Values[ds[Reverse@*SortBy[#votes&]][All,{"votes"}]]]],PlotRange->All,AxesLabel->{"Rank","Number of votes"},PlotMarkers->{Automatic,Medium}] ![enter image description here][4] Let's look into my posts: ds[Select[#creator=="Sander Huisman"&]/*Reverse@*SortBy[#votes&]] ![enter image description here][5] I'm very happy to see some of my posts got ~50 votes. Let's have a look at the authors, who is the most active in making threads: data=SortBy[Tally[Flatten[Normal[Values[ds[[All,{"creator"}]]]]]],Minus@*Last][[;;50]]; BarChart[Association[Rule@@@Reverse@data],ChartLabels->Automatic,BarOrigin->Left,Frame->True,PerformanceGoal->"Speed",AspectRatio->GoldenRatio/2,ChartStyle->Directive[EdgeForm[{Thickness[Medium],Black,Opacity[1]}],RGBColor[0,0.5,1]],FrameStyle->Black,FrameTicks->{{Automatic,Automatic},{All,All}},ImageSize->650,PlotRange->{0,160},PlotRangePadding->{None,{None,Scaled[0.01]}},BarSpacing->None,PlotLabel->Style["Number of threads",16,Black]] ![enter image description here][6] [@Clayton Shonkwiler][at0] is by far the author with the most posts. We can also check by number of votes: BarChart[Sort[GroupBy[Normal[Values[ds[[All,{"creator","votes"}]]]],First->Last,Total]][[-100;;]],ChartLabels->Automatic,BarOrigin->Left,Frame->True,PerformanceGoal->"Speed",ScalingFunctions->"Log",AspectRatio->GoldenRatio,ChartStyle->Directive[EdgeForm[{Thickness[Medium],Black,Opacity[1]}],RGBColor[0,0.5,1]],FrameStyle->Black,FrameTicks->{{Automatic,Automatic},{All,All}},ImageSize->650,PlotRange->{20,3000},PlotRangePadding->{None,{None,Scaled[0.01]}},PlotLabel->Style["Total number of votes",16,Black]] ![enter image description here][7] I was surprised to see I end up second in this list! Finally let's make a word cloud of the topic-titles: WordCloud[ToLowerCase[StringRiffle[Flatten[Normal[Values[ds[[All,{"title"}]]]]]]],MaxItems->150] ![enter image description here][8] Hope you enjoyed this little exploration, even further analysis would be to download all the threads, but that would be quite the undertaking without access to the database directly… [at0]: http://community.wolfram.com/web/claytonshonkwiler [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-01-01at23.08.20.png&userId=73716 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-01-01at23.09.59.png&userId=73716 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-01-01at23.12.56.png&userId=73716 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=rank.png&userId=73716 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-01-01at23.16.41.png&userId=73716 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-01-01at23.18.32.png&userId=73716 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1517out.png&userId=73716 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-01-01at23.22.11.png&userId=73716 Sander Huisman 2018-01-01T22:27:37Z https://community.wolfram.com/groups/-/m/t/1136926 Project on GitHub: https://github.com/lne817/WSS-17 ---------- Patent Claims Analytics ======================= ---------- Patent claims are formally worded statements within a patent application or patent, which clearly explain the invention, and define the scope of the invention. In order to enforce the full scope of a patent, it is imperative for inventors, firms, and companies to make sure that the patent's scope is not covered by prior publications and competitors' patents (referred to as "prior art") available in the public domain. For this reason, most companies with a patent portfolio spend a substantial amount of resources in searching for potentially troubling prior art. Therefore, this project is a first step to optimize this process and offers an analytic tool to better categorize and analyze the relationship between a granted patent with other patents by clustering them based on claim term frequency. --------- **Constructing Patent Analysis Dataset** Patent grant full text (without images) from USPTO Bulk Data Storage System (https://bulkdata.uspto.gov) are downloaded as zip files and extracted into xml files. Each patent is parsed by separating with headings of xml files and parsed. For each patent, patent information including the patent number, title, number of claims, claim text, three most frequently used words is extracted. parsePatent[files_, numberOfPatents: (n_?IntegerQ /; Positive[n])|All, streamPosition_ : 0] := Module[ {patentsStream, patent}, patentsStream = OpenRead[files]; SetStreamPosition[patentsStream, streamPosition]; Do[readPatent[Find[patentsStream, "<doc-number>", RecordSeparators -> {{"<?xml version=\"1.0\" encoding=\"UTF-8\"?>"}, {"</us-patent-grant>"}}]], numberOfPatents]; Close[patentsStream]; ] readPatent[patent_] := Module[ {patentStream, patentInfoList, patentInfoRaw, patentInfo, claimsRaw, claims, words}, patentStream = StringToStream[patent]; patentInfoList = {"<doc-number>", "<invention-title id=", "<number-of-claims>"}; patentInfoRaw = Find[patentStream, #] & /@ patentInfoList; patentInfo = StringReplace[patentInfoRaw, Shortest["<"~~__~~">"] -> ""]; claimsRaw = FindList[patentStream, "<claim-text>"]; claims = StringReplace[StringJoin[claimsRaw], {Shortest["<"~~__~~">"] -> " ", StringExpression[a:NumberString,"."] -> StringExpression[ToExpression[a],":"]}]; AssociateTo[claimText, {patentInfo[[1]] -> claims}]; words = DeleteCases[base[StringDelete[DeleteStopwords[ToLowerCase[StringJoin[claims, " ", patentInfo[[2]]]]], Alternatives@@dropList]], Alternatives@@blackList]; AppendTo[patentAnalysisMatrix, <|patentInfo[[1]] -> <|"Title" -> patentInfo[[2]], "# Claims" -> patentInfo[[3]], "Words" -> Select[Keys[WordCounts[words]], LetterQ][[1;;3]]|>|>]; (*Print[WordCloud[words]]*) Close[patentStream]; ] The most frequently used words are cleaned with separate lists of words to be dropped for better characterizing each patent. Clear@base; base[w_] := With[{tmp = WordData[w, "BaseForm", "List"]}, If[(Head[tmp] === Missing) || tmp === {}, w, tmp[[1]]]]; SetAttributes[base, Listable]; blackList = {"doi", "ed", "isbn", "pmid"}; dropList = {"wherein", "claim", "said", "-", "&#", "x2018", "x2019", "x201c", "x201d", ";", "/", "'", ".", StringExpression[" ", NumberString, " "], StringExpression[" ", NumberString, ", "]}; Then, we obtained a dataset with three most frequently used words in each patent for further analyses. ![Patent information dataset with three most frequently used words in each patent.][1] --------- **Clustering with Vector Representations of Words with NetModel, GloVe** GloVe is used to turn three most frequently used words in claim text into [3 x 100]-dimensional vector representations, allowing us to group them together with semantically similar data in a vector space. net = NetModel[ "GloVe 100-Dimensional Word Vectors Trained on Wikipedia and Gigaword-5 Data"] wordToVec = net /@ Normal[patentAnalysisMatrix[All, "Words"]]; Dimensions /@ wordToVec // Tally (* Same dimension checked *) c = ClusterClassify[Values[wordToVec]] --------- **Time-Series Data using USPTO's Classification Systems** Patents are classified by the USPTO into patent classes and subclasses based on the subject matter of the patent claims. Thus, we can use patent class/subclass information to group or cluster patents that have common claimed subject matter. Here, instead of the USTPO's patent classification systems which have large numbers of categories and largely designed for administrative purposes, thus limiting their value for research purposes, the National Bureau of Economic Research (NBER) categories, which Hall, Jaffe, and Trajtenberg (2001) developed by aggregating USPC classes into six economically relevant technology categories (and 37 sub-categories) and classified granted patents accordingly, were applied to create the times series data. The number of patent grants in Computers & Communication has been greatly increased, suggesting that they are more probable to be invalidated and the applicants would need more than mere implementation for their inventions to be patent eligible. ![Patent grant counts per category per year.][2] --------- **Scope Checker** Lastly, we often need to explore the description (or specification) part of patent documents to clarify the scope and details which are claimed in the patent. There is also a requirement for a patent application called "Sufficiency of Disclosure" which means that it should contain sufficient information or details of patent claims so that others can reproduce. Therefore, by constructing the distance matrix between the claim sentence and description sentences, we would be able to find the most similar and related text with a given claim sentence. patentScopeChecker[files_, patentNum_, claimNum_] := Module[ {patentsStream, patent, patentTitleRaw, patentTitle, patentText, patentTextRaw, patentSpec, claimsRaw, claims}, patentsStream = OpenRead[files]; patent = Find[patentsStream, patentNum, RecordSeparators -> {{"<?xml version=\"1.0\" \ encoding=\"UTF-8\"?>"}, {"</us-patent-grant>"}}]; patentTitleRaw = StringCases[patent, Shortest["<invention-title id=" ~~ __ ~~ "</invention-title>"]][[1]]; patentTitle = StringReplace[patentTitleRaw, Shortest["<" ~~ __ ~~ ">"] -> ""]; patentSpec = StringReplace[StringCases[patent, Shortest["<description id=" ~~ __ ~~ "</description>"]], "\n" -> " "]; patentTextRaw = StringReplace[patentSpec, {Shortest["<" ~~ __ ~~ ">"] -> "", StringExpression[NumberString, "."] -> ""}]; patentText = TextSentences[StringJoin[patentTextRaw]]; claimsRaw = StringReplace[StringCases[patent, Shortest["<claims id=" ~~ __ ~~ "</claims>"]], "\n" -> " "]; claims = Flatten[TextSentences[StringTrim[StringReplace[claimsRaw, {Shortest["<" ~~ __ ~~ ">"] -> "", StringExpression[a : NumberString, "."] -> StringExpression[ToExpression[a], ":"]}]]]]; Print["Title: ", patentTitle, "\nClaim: ", claims[[claimNum]], "\nDescription:", Nearest[patentText, claims[[claimNum]], 3]]; PrependTo[patentText, claims[[claimNum]]]; distanceToText = DistanceMatrix[patentText][[1]]; Print[distanceToText] // MatrixForm; Print[ListLinePlot[distanceToText]]; Print[NearestNeighborGraph[patentText, VertexLabels -> {patentText[[1]] -> "Claim"}]]; Close[patentsStream]; ] Searching for details of the claim 2 in US8407580, one of the patents by Stephen Wolfram, demonstrates that the Scope Checker successfully detects the relevant details in the description/specification part of a patent document for a given claim text. These sentences correspond to the three smallest values in the DistanceMatrix between the claim text and the description text, and NearestNeighborMatrix demonstrates how the claim text is related to the description text. ![Find by the patent number within known file name ("ipgYYMMDD.xml" for known publication date).][3] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=project1.png&userId=1122853 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=project3.PNG&userId=1122853 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=project4.PNG&userId=1122853 Nae Eoun Lee 2017-07-05T20:48:00Z https://community.wolfram.com/groups/-/m/t/1137218 The goal of OCR (Optical Character Recognition) is to recognize characters in images. Here is how I used convolutional neural network to create an OCR working on images of single characters that supports 8 major writing systems: Arabic, Chinese, Cyrillic, Devanagari, Greek, Japanese, Korean, and Latin. ## Neural Network ## I developed my neural network based on LeNet by adding batch normalization layers, dropout layers, and more convolutional layers. Here is the architecture of my network: OUCR = NetChain[{ ConvolutionLayer[32, {5, 5}, "PaddingSize" -> {2, 2}, "Stride" -> 2], BatchNormalizationLayer["Input" -> {32, 32, 32}], ElementwiseLayer[Ramp], PoolingLayer[{2, 2}, {2, 2}], ConvolutionLayer[64, {3, 3}, "PaddingSize" -> {1, 1}], BatchNormalizationLayer["Input" -> {64, 16, 16}], ElementwiseLayer[Ramp], PoolingLayer[{2, 2}, {2, 2}], ConvolutionLayer[128, {3, 3}, "PaddingSize" -> {1, 1}], BatchNormalizationLayer["Input" -> {128, 8, 8}], ElementwiseLayer[Ramp], PoolingLayer[{2, 2}, {2, 2}], ConvolutionLayer[256, {3, 3}, "PaddingSize" -> {1, 1}], BatchNormalizationLayer["Input" -> {256, 4, 4}], ElementwiseLayer[Ramp], PoolingLayer[{2, 2}, {2, 2}], FlattenLayer[], DropoutLayer[0.5], LinearLayer[], SoftmaxLayer[] }, "Output" -> NetDecoder[{"Class", unicode}], "Input" -> NetEncoder[{"Image", {64, 64}, "Grayscale", "MeanImage" -> 0.85}] ] The first convolutional layer has kernels of size 5 and stride 2 to reduce the influence of noise. The fully connected layers are very simple due to the large volume (over 32000) of classes. ## Training Set ## To train my neural network, I generated over a million images of characters with different fonts and rotations using Mathematica. At first I used Rasterize[], which turned out to be so slow that it would take tens of hours to generate all the images. So I improved my algorithm by using Image[], Graphics[], and Text[] instead, which took only a few minutes. Here are the two functions I designed to generate images: unrotated[list_, size_, scale_, font_, horizontal_, vertical_] := Module[{len, col, row}, len = Length[list]; col = Floor[Sqrt[len]]; row = Ceiling[len / col]; Thread[(Join @@ ImagePartition[ Image[ Graphics[ MapIndexed[ Text[ Style[#1, FontFamily -> font, FontSize -> Scaled[scale / col]], Reverse[#2]] &, Reverse[ Partition[FromCharacterCode /@ list, UpTo[col]] ],{2}], PlotRange -> {{horizontal, col + horizontal}, {vertical, row + vertical}}, ImageSize -> {size * col, size * row}], ColorSpace -> "Grayscale"], size])[[;; len]] -> FromCharacterCode /@ list]] rotated[list_, size_, scale_, font_, angle_, horizontal_, vertical_] := Module[{len, col, row}, len = Length[list]; col = Floor[Sqrt[len]]; row = Ceiling[len / col]; Thread[(Join @@ ImagePartition[ Image[ Graphics[ MapIndexed[ Rotate[ Text[ Style[#1, FontFamily -> font, FontSize -> Scaled[scale / col]], Reverse@#2], RandomVariate[ NormalDistribution[0, angle]] Degree] &, Reverse[ Partition[FromCharacterCode /@ list, UpTo[col]] ], {2}], PlotRange -> {{horizontal, col + horizontal}, {vertical, row + vertical}}, ImageSize -> {size * col, size * row}], ColorSpace -> "Grayscale"], size])[[;; len]] -> FromCharacterCode /@ list]] These functions take a list of Unicodes and generate images of unrotated and rotated characters of the corresponding Unicodes. There are several tunable parameters. "size" controls the size of the images (size * size), where I used 64 for my training set. "scale" controls the scale of characters in images, where I found 0.7~0.8 suitable for most writing systems and fonts. For "font", I chose several fonts for each language to make the characters as diverse as possible. "horizontal" and "vertical" are compensations, where 0.5 works for most cases. rotated[] also takes "angle" and generates rotated images whose rotational angles follow a normal distribution with standard deviation of "angle" degrees, where I used 4 degrees in most cases. For each font of each writing system, I generated 1 unrotated and 3 rotated images for the training set and 1 rotated image for the validation set. There was no obvious overfitting or underfitting during the training process, and after 70 rounds of training, the validation loss was down to 5*10^-3. ## Tests ## Here is the bar chart of accuracies recognizing characters of each writing system, tested on random samples with random fonts and random rotations: ![enter image description here][1] The accuracies recognizing Cyrillic, Greek, and Latin characters are rather low because some of their characters are very similar. The accuracy recognizing Latin characters is especially low because I tested on a random sample of all fonts, and Latin characters can look very different in different fonts, while many fonts don't support other writing systems. Here is the bar chart of accuracies recognizing a random sample of 200 Chinese characters, tested on characters generated by the computer (different fonts), handwritten by Yan, Zhenqing (709-785, one of the best calligraphers in Chinese history, images from http://www.shufazidian.com/), and handwritten by myself (written on paper, scanned, and processed using Mathematica): ![enter image description here][2] Two short examples of how it works (first handwritten by Yan, second handwritten by myself): ![enter image description here][3] I also tested my network on many variations of the images, including blurring, adding noise, distortion, zooming in and out, horizontal and vertical movement, and rotation: ![enter image description here][4] ![enter image description here][5] ![enter image description here][6] ![enter image description here][7] ![enter image description here][8] ![enter image description here][9] ![enter image description here][10] ## Acknowledgements ## I would like to thank my mentor Vladimir Grankovsky for helping me along the whole project and Matteo Salvarezza and Timothée Verdier for helping me set up AWS GPU computing services. ## References ## 1. Image source for Yan's handwritten Chinese characters: http://www.shufazidian.com/ 2. My GitHub repository: https://github.com/MatthewChen7211/WSS2017 [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=6830WS.png&userId=1123149 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1449HW.png&userId=1123149 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-07-05at5.21.25PM.png&userId=1123149 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Blur.png&userId=1123149 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Noise.png&userId=1123149 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Distortion.png&userId=1123149 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Zoom.png&userId=1123149 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Horizontal.png&userId=1123149 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Vertical.png&userId=1123149 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Rotate.png&userId=1123149 Matthew Chen 2017-07-05T21:51:05Z https://community.wolfram.com/groups/-/m/t/1136795 The goal of this project was to create an algorithm that would be able to describe the scope of knowledge covered in Wikipedia. The task was approached as a classification problem. Problem ------- In the case of Wikipedia, classification is difficult mainly for two reasons: 1. The scope keeps changing as new articles are being added and new linkages between articles are created; 2. Similar vocabularies may be used to describe totally different concepts in different contexts. When a new article is added, simple classification based on content is may be insufficient because it is difficult to categorize the content that is not similar to the previously learned. Links provide immediate help as it is safe to assume that a large portion of the linked articles discuss related and similar issues. Solution outline ---------------- To include both content and links, I based my solution on Iterative Classification Algorithms whose basic idea is the minimization of dissimilarity in the categories of closely linked articles. The implementation involved two classifiers: 1. A basic Content Classifier used the most frequently used words as a feature vector 2. A Relational Classifier used the occurrence of categories in the linked articles as a feature vector. In the following sections, data preparation/feature extraction methods for each classifier is explained. Then the code for each classifier is outlined. Finally, the combined application of the two classifiers and the benefits of such combination are discussed. In conclusion, the outline for the future development of this project is detailed. Classifiers ----------- In the ICA, the initial content categories or labels are “guessed” and then further improved. The “guessing” or initial approximation is used for training the relational and the content classifiers. In the project, the training data was extracted starting from a randomly selected article (“Activism” in this particular analysis) and collecting further linked articles until the sample size of ~4000 articles was reached. These articles were initially classified for training using: topicCheck = Classify["FacebookTopic"] Relational Classifier feature extraction ======================================== getWikiLinks := Function[{articleName}, linkText = WikipediaData[articleName, "SummaryWikicode"]; list = StringCases[linkText, Shortest["[[" ~~ x__ ~~ "]]"] :> ToString[x]]; list1 = DeleteCases[ list, _?((StringTake[#, Min[StringLength[#], 4]] == "File" || StringTake[#, Min[StringLength[#], 4]] == "Imag") &)]; Clear[strListClear]; strListClear := (If [StringPosition[#, "|"] != {}, pos = StringPosition[#, "|"][[1, 1]]; StringTake[#, pos - 1], #]) &; listOfLinks = Map[strListClear, list1]; listOfLinks = Union[listOfLinks]] Loop through the links: getWikiLinksAndAdd := Function[temp = getWikiLinks[#]; tempInitialIds = Table[#, Length[temp]] ; tempDataLinks0 = Transpose[{tempInitialIds, temp}]; {temp, tempDataLinks0 }] the results of the function were saved into a file, e.g.: > Activism artivism > Activism boycott > Activism civic engagement > Activism Civil Rights Movement > ….. and so on.* This file was further used in the relational classifier. Content classifier: Data preparation and feature extraction =========================================================== For the content classifier, the same articles as in the relational classifier were extracted, however instead of Wikicode, plain text summary was used. The articles were classified using topicCheck classifier created above. Further, a list of most frequent nouns was extracted from each article, combined from all articles into the list of keywords and used to create a feature vector. CreateContentFile:= Function[{uniqueArticle}, text = ToString[WikipediaData[uniqueArticle, "SummaryPlaintext"]]; label = topicCheck[text]; nouns = TextCases[text, "Noun"]; (*nouns = Pluralize/@ nouns;*) nouns = DeleteStopwords[ToLowerCase[nouns]]; freqnouns=Sort[Counts[nouns], Greater]; features =If[Length[freqnouns]>=1,Keys[freqnouns][[1]],""]; {features, label} ] Article names, keywords, and labels were saved into wiki.content file. This file was then used to create feature vectors: finalAllTRead = Import["wiki.content", "Table"] The features in the feature vector were assigned based on the occurrence of the keyword’s stem in the article’s summary: For[k1 = 1, k1 <= Length[finalAllTRead], k1++, featureVector = Table[0, Length[keywords]]; kw = ToString[finalAllTRead[[k1, 2]]]; For[k2 = 1, k2 <= Length[keywords], k2++, If[ StringPosition[kw, keywords[[k2]]] != {}, featureVector[[k2]] = 1]]; finalAllTRead[[k1, 2]] = featureVector] The feature vector was saved into a separate file: Export["wikifeature.content", finalAllTRead[[All, 2]], "Table"] Content Classifier ================== Content classifier was trained using wiki.content and wikifeature.content data and logistic regression: localClf=Classify[selectedFeatures?selectedLabels,Method?"LogisticRegression"]; Relational Classifier ===================== The relational classifier was also based on logistic regression and the data stored in wiki.cites file. However, before the data in the file could be used for regression purposes, it had to be transformed into suitable feature arrays and labels. The feature array had the length equal to the number of unique labels and was constructed based on the occurrence of a particular label in the article’s neighbours (the articles linked to the current): aggregate[conditionalMap_, vertice_, features1_] :=(*returns a matrix: rows equal to training sample, \ columns equal to dataLabels equal to the amount of dataLabels in the \ find all connected indices*)( tempFeatures = List[features1][[1]]; neighboursR = Select[dataLinks, Part[#, 1] == vertice &]; neighboursR = neighboursR[[All, 2]]; neighboursL = Select[dataLinks, Part[#, 2] == vertice &]; neighboursL = neighboursL[[All, 1]]; neighbours = Join[neighboursL, neighboursR]; For[j = 1, j <= Length[neighbours], j++, node = neighbours[[j]]; labelToReinforce = Select[conditionalMap, Part[#, 1] == node &]; If[labelToReinforce != {}, k = Flatten[ Position[uniqueLabels, labelToReinforce[[All, 2]][[1]]]][[1]]; If[features1[[k]] >= 0, tempFeatures[[k]] ++]; ]; ]; tempFeatures ) For [i = 1, i <= Length[trainIds], i++, ( selectedFeatures1 = aggregate[conditionalMap, selectedNodes[[i]], selectedFeatures[[i]]]; selectedFeatures[[i]] = selectedFeatures1; )]; Further, the labels and the feature arrays were used in the logistic regression: relClf = Classify[selectedFeatures -> selectedLabels, Method -> "LogisticRegression"] Combining the Classifiers ========================= In the ICA, combining classifiers is used to find the optimum labels by adjusting the labels in the relational classifier in an iterated fashion until the least label diversity in the directly linked articles is reached. This was not fully implemented in the project, however, the availability of two different classifiers allowed to select the classifier with higher accuracy and choose the answer with higher probability: relLabel = relClf[testFeature][[1]] relClf[testFeature, "TopProbabilities"] relLabelProbaility = relClf[testFeature, "TopProbabilities"][[1]][[1, 2]] localLabel = localClf[dataFeatures[[1]]] localLabelProb = localClf[dataFeatures[[1]], "TopProbabilities"][[1, 2]] The cases where the prediction of the Content Classifier differed from the Relational classifier, and both classifiers were not confident of the answer were treated as an indication for the need of a new label: If[(localLabel != relLabel && localLabelProb < 0.5 && relLabelProbaility < 0.5), newLabel = topicCheck[ToString[getText[dataContent[[dataIds[[58]]]][[1]]]] ]; newId = Max[dataIds] + 1; AppendTo[conditionalMap, {newId, newLabel}]; newFeatures = {(*recreates the feature vectors*)}] Future development ------------------ The most obvious future development is the implementation of the full ICA. It would also require improvements in the data preparation procedures and the automation of the feature vectors update when a new label is created. The current solution was based on links in Wikicode, however, it can be extended to the analysis of Natural text as the linkages in text may be inferred from phrases like “this means that” or “this explains that” and so on. The extension of the algorithm to the meaning extraction from the natural text should be the next goal of this project. The code for this analysis is available on GitHub: [WikiClassify][1] [1]: https://github.com/tetyanaloskutova/TetyanaWSS2017/tree/master/WikiClassify Tetyana Loskutova 2017-07-05T21:22:04Z https://community.wolfram.com/groups/-/m/t/1011732 Hi Wolfram Community, This post is a branch from Vitaliy's earlier thread about textual comparison. I find online pdf translations for "Heart of a Dog" and process the text as follows: [PDF Source 1][1] $\longrightarrow$ [plaintext cipher][2] [PDF Source 2][3] $\longrightarrow$ [plaintext cipher][4] It's easy to get going right away with word-by-word analysis, and I produce the following distribution of words, showing fluctuations between the texts: ParsedTexts = StringSplit[#," "]&/@TextStrings (* as in the ciphers hyperlinked above *) Length /@ ParsedTexts Length[Union[#]] & /@ ParsedTexts Out[1] = {32399, 34772} Out[2] = {5060, 5197} Tallies = Tally /@ ParsedTexts; Words = Union @@ ParsedTexts; AbsoluteTiming[ CompareCounts = ReplaceAll[ Prepend[(Function[{a}, Cases[Tallies[[a]], {#, b_} :> b]] /@ {1, 2}), #] & /@ Words, {{} -> 0, {x_Integer} :> x}]; ] CompareDiff = CompareCounts /. {x_, y_, z_} :> {x, y - z}; Histogram[CompareDiff[[All, 2]], PlotRange -> {{-10, 10}, {0, 3000}}] ![Diff Distribution][5] The graph shows preponderance of difference around $0$, and the texts each contain about 2000 words not found in the other. This is by no means a perfect analysis, and probably contains some processing errors, so should be taken lightly. Now we can also import [Vitaliy's algorithm][6] and find some interesting results: 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 + .9 wordsTOP[[All, 2]]], VertexLabels -> Automatic, VertexLabelStyle -> Directive[20, White, Opacity[.8]], GraphStyle -> "Prototype", Background -> Black], CommunityBoundaryStyle -> Directive[GrayLevel[.4], Dashed], CommunityRegionStyle -> GrayLevel[.2], ImageSize -> 500 {1, 1}, PlotRangePadding -> {{.1, .3}, {0.1, 0.1}}]] {ideaNET[StringJoin[StringRiffle[#, " "]], .15] & /@ ParsedTexts, ideaNET[StringJoin[StringRiffle[#, " "]], .1] & /@ ParsedTexts} // TableForm ![enter image description here][7] So we see that applying a variation of the cut parameter causes a bifurcation in the graphs. What is the meaning of this bifurcation? It's especially intriguing when you consider that one translation graph has Zina and Darya in the same community, while the other has Zina and Darya in seperate communites. I don't know much about the function CommunityGraphPlot, so maybe one of the experts here would care to comment on the meaning of this discrepancy? In any case, it's nice to see this technology put to some positive use, as I would not be interested in the least, to see a graph of some social networking site. What is the next step in our Magnificent Integral? We could possibly find a way to rip the subtitles out of the following video adaptation from 1988, during the Dissolution of the Soviet Union: [ ??????? ?????? (1988) ][8] ! To conclude, let's do one last comparison of the cipher texts: According to my calculations, the name "Vasnetsova" appears twice in one of the translated texts and zero times in the other. It's reminding me of a painting I've seen from inside St. Vladimir's Cathedral in Kiev, [The Russian Bishops][9]. Someday it would be nice to visit the Bulgakov Museum and to tour the cathedral, but I'm afraid it's not the year to do so. Bradley Klee [1]: http://www.arvindguptatoys.com/arvindgupta/29r.pdf [2]: https://ptpb.pw/8R6e [3]: http://www.masterandmargarita.eu/archieven/tekstenbulgakov/heartdog.pdf [4]: https://ptpb.pw/_6dj [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=5607Comparison.png&userId=234448 [6]: http://community.wolfram.com/groups/-/m/t/1007290 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=IdeaNet.png&userId=234448 [8]: https://www.reelhouse.org/vintagefilmclub/the-heart-of-a-dog/video [9]: https://upload.wikimedia.org/wikipedia/commons/0/06/Vasnetsov_Russian_Bishops.jpg Brad Klee 2017-02-10T20:35:49Z https://community.wolfram.com/groups/-/m/t/908823 **User Clustering by their Social Behaviour** ------------------- ![enter image description here][1] My main goal in this project was to classify internet users using information publicly available on social sites. Among the many alternatives, I chose Reddit because I was able to find a rich database. [Database][2]—the whole set of comments posted during May of 2015. The main steps of my project have been - Learning how to work with an SQL database in Mathematica - Collecting information about random users - Analysing the relevance of the Subreddit present in the data - Creating a user feature vector - Clustering the users through their feature representation ##Learning how to use the Database To start working on the database, I first checked the [database description][3] in order to correctly manipulate the data. To do that I need to know how to open SQLITE files in Mathematica. We must check the [database description][4] in order to correctly manipulate the data. As it was my first time, I wanted to start easy to get an idea of what could be done. For that I chose one random person from the dataset, and then tried to collect information about him (or her). I got up to 1000 rows and the columns "subreddit" and "score", but only if the value in the column "author" was "WyaOfWade" (a random user's name). subreddit.commentsScore=SQLSelect[database,"May2015",{"subreddit","score"}, SQLColumn[{"May2015","author"}]=="WyaOfWade", "MaxRows"->1000]; Then I grouped the results by the first element ("subreddit") returning the last one ("score"), and computing the length of the vector to see how many comments are on a given GroupBy[commentsScore, First -> Last, Length] The result in Column form is nba->306 nfl->2 CoDCompetitive->32 hiphopheads->17 Boxing->2 GlobalOffensive->6 headphones->8 food->1 pcmasterrace->1 leagueoflegends->4 malefashionadvice->4 DotA2->3 Music->2 OpTicGaming->10 leakthreads->2 AskReddit->1 todayilearned->1 Games->1 So now we have some information about a random user and can for example make a histogram for a more presentable form. Here are the the top 3 subreddits where he/she is commenting. ![enter image description here][5] ##Starting with Statistics Now we can gather statistics about more than one user, for example the first 10,000 users in the database. To reduce the noise in the data, we filter them by quantity of comments and take all users that have more than 20 comments in some subreddits. minLength=20; commentPerSub=Map[Select[GroupBy[#,First->Last,Length],#>minLength&]&, data]; Short[commentPerSub,2] <|rx109-><|newsokur->222,BakaNewsJP->37|>,WyaOfWade-><|nba->306,CoDCompetitive->32|>, Wicked_Truth-><|politics->156|>,jesse9o3-><|AskReddit->54,worldnews->275,soccer->28|>, <<7516>>,Zandock-><|fireemblem->57|>,RandomRem-><||>,Op69dong-><||>|> This way we find ourseves with 4468 users. Here is the distribution of the amount of subreddits each user commented in. Most users only have significant activity (more than 20 comments) in one subreddit. ![enter image description here][6] ##Subreddit analysis It's time to start the Subreddit analysis. I first got the list of all subs (1812 of them are present in my data). allSubs = Merge[Values[commentPerSub], Total]; Length[allSubs] 1812 Here are the first five by number of comments TakeLargest[allSubs, 5] <|"AskReddit" -> 85288, "nba" -> 48097, "nfl" -> 43888, "leagueoflegends" -> 27483, "hockey" -> 18535|> We can see that AskReddit is very popular sub so user commenting on it are probably not very correlated by interestsTherefore I decided to drop it from the list. Now I can have a look at the plot of each subreddit vs its number of comments. ![enter image description here][7] ##User representation Now I have enough information about subreddits and users for creating user vectors which we will use in user's classification.So let's create an empty user vector with zero comments for each sub, then replace the values for each user into empty vector.The new association as values for each subreddit. (*Create an empty user vector with zero comments for each sub*) userVectorEmpty = Association[Thread[Keys[allSubs] -> 0]]; Short[userVectorEmpty] <|newsokur->0,BakaNewsJP->0,nba->0,<<1806>>,shorthairedhotties->0,uwaterloo->0|> (*Replace values for each user into the empty vector*) extendedCommentPerSub = Join[userVectorEmpty, #] & /@ Values[commentPerSub]; The new association as values for each subreddit First[commentPerSub] Short[First[extendedCommentPerSub]] <|newsokur->222,BakaNewsJP->37|> <|newsokur->222,BakaNewsJP->37,nba->0,<<1806>>,shorthairedhotties->0,uwaterloo->0|> (*Create an empty user vector with zero comments for each sub and remove the \ subreddit names*) userVectors = Values[Join[userVectorEmpty, #]] & /@ commentPerSub; (*save the name of the users*) userNames = Keys[userVectors]; (*remove also the keys with the users, now userVectors is just a normal \ matrix*) userVectors = Values[userVectors]; (*normalize each vector user by dividing for the total number of comments per \ subreddit*) userVectors = Transpose[Transpose[userVectors]/Values[allSubs]]; This is a plot of all the users vectors. ![enter image description here][8] ##User classification We want to build a similarity function to identify users with common interests similarity[v1_,v2_]:=v1.v2/(Norm[v1]Norm[v2]) The norm at the denominator are computed separately for efficiency norms=Norm/@N[userVectors]; normMatrix=Transpose[{norms}].{norms}; This builds the similarity matrix similarityMatrix=N[userVectors].Transpose[N[userVectors]]/normMatrix; I want all the values below a certain threshold to be zero. I.e. no connection between the users. I also subtract the diagonal not to connect users with themselves similarityThreshold=.75; m2=Threshold[similarityMatrix-IdentityMatrix[Length[userVectors]],similarityThreshold]; All the rest is set to one m3=Ceiling[m2]; Now the graph is build from the adjacency matrix AdjacencyGraph[m3] ![enter image description here][9] In this graph there are 1625 disconnected components graphComponents=ConnectedGraphComponents[fullGraph]; Length[graphComponents] 1625 If I remove the components with only one element (i. e. the cluster of only one user) I am down to 592 graphComponents=Select[graphComponents,VertexCount[#]>1&]; Length[graphComponents] 592 Each disconnected component represent now a group of users with similar commenting patterns---and hopefully similar interests. Here are five of them Grid[{#,commentPerSub[[VertexList[#]]]}&/@RandomSample[graphComponents,5]] ![enter image description here][10] As we can see all these group of users have high activity on the same Subreddits. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=UserClassifier.png&userId=900523 [2]: https://www.kaggle.com/reddit/reddit-comments-may-2015 [3]: https://www.kaggle.com/reddit/reddit-comments-may-2015 [4]: https://www.kaggle.com/reddit/reddit-comments-may-2015 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot_1.png&userId=900523 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Plorium.png&userId=900523 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-08-19at15.17.15.png&userId=900523 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=SqlExplore4.png&userId=900523 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2410Final_05.png&userId=900523 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=5examples.png&userId=900523 Armen Barseghyan 2016-08-19T15:19:08Z https://community.wolfram.com/groups/-/m/t/908332 **Abstract** The goal of this project is to implement the Huffman lossless data compression algorithm which is a compression algorithm based on the frequency of data. The trick is that the words which are more commonly used must be shorter than the words which are less common. The English language already uses this approach, for example, the word "the" is frequently used and short but the word "approximation", which is much less frequent is longer. - Introduction to Huffman coding - Word frequency data - Huffman algorithm code in Mathematica and a few examples - Correlation between words and Huffman codes **Introduction to Huffman coding** Huffman coding is a statistical technique, which attempts to reduce the amount of bits required to represent a string or a symbol. The concept of Huffman algorithm is that the shorter binary codes are assigned to the most frequently used symbols and longer codes to the symbols which appear less frequently. The Huffman code for an alphabet (set of symbols or words) may be generated by constructing a binary tree with nodes containing the symbols to be encoded and their probabilities of occurrence (that's where the statistical part comes in). This means that you must know all of the symbols that will be encoded and their probabilities prior to constructing a tree. In computer science and information theory, a Huffman code is a particular type of optimal prefix code that is commonly used for lossless data compression. The algorithm was originally developed by David A. Huffman. **Word frequency data:** As an input for the Huffman coding algorithm, we use the 5000 most frequently used words in English. See the database [Here][1]. The following is the visualization of most commonly used words, $\qquad \qquad \qquad \qquad \qquad \qquad $![enter image description here][2] **Examples of Huffman codes** merge[k_] := Replace[k, {{a_, aC_}, {b_, bC_}, rest___} :> {{{a, b}, aC + bC}, rest}]; mergeSort[d_List] := FixedPoint[merge @ SortBy[#, Last] &, d][[1, 1]]; findPosition[l_List, k_List] := Map[ (# -> Flatten[Position[k, #] - 1]) &, DeleteDuplicates[l] ]; huffman[l_List] := Module[{sortList, code, words}, words = l[[All, 1]]; sortList = mergeSort[l]; code = findPosition[words, sortList]; {Flatten[l /. code], code}; code ] These are a few examples of encoded words using Huffman algorithm $\qquad \qquad \qquad \qquad \qquad \qquad $![enter image description here][3] **Correlation between words and Huffman codes** The following is the correlation plot of the numbers of letters in a word and number of bits produced by Huffman algorithm. As you can see from the plot the most commonly used words in English tend to be shorter and the overall the trend in English and in Huffman code is the same. $\qquad \qquad \qquad \qquad \qquad \qquad $![enter image description here][4] The following plot represents the number of bits of English words and the number of bits of Huffman codes. The number of bits per English word was computed using a conversion factor of $\log_2(26) ~ 4.7$ bits per word, where 26 is the number of letters in the English alphabet. $\qquad \qquad \qquad \qquad \qquad \qquad $![enter image description here][5] The blue line is a scatter plot of the number of bits in English versus the number of bits in the Huffman code. The red line is $y=x$. .As you can see the Huffman coding is much more efficient and the slope of the curve tells us that the Huffman coding uses three times less space than the English language. [1]: https://en.wiktionary.org/wiki/Wiktionary:Frequency_lists/PG/2006/04/1-10000 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=wordcloud.png&userId=900670 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Matrix.PNG&userId=900670 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=corr.png&userId=900670 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=5310corr.png&userId=900670 Vahagn Hayrapetyan 2016-08-19T12:34:09Z https://community.wolfram.com/groups/-/m/t/796831 [Martin Hadley][1] and I are organizing a 5-day Wolfram Language workshop at Oxford’s [Digital Humanities Summer School][2] “Analysing Humanities Data: An Introduction to Knowledge-Based Computing with the Wolfram Language”. Here’s a brief overview from the course description: > This example-led workshop will provide a comprehensive introduction to techniques for analysing a wide range of humanities data with the Wolfram Language; from text analysis, image processing, and visualization, to network analysis, time-related and geographic computation, and machine learning. The course assumes no prior knowledge of any programming language. Participants will learn the concepts needed to import, manipulate, and analyse humanities data using both the natural-language input and scripted interfaces to the Wolfram Language and to share their data and applications in the cloud. Part of the material in the course will be drawn from William Turkel’s open-access textbook, *[Digital Research Methods with Mathematica][3]*  We’re looking for one or two experienced WL users who would be interested in coming to Oxford between July 4th and 8th (at our expense, naturally) to give a c. 3/4 or hour long presentation/talk on some aspect of the WL relevant to the humanities. This need not be text related! Yes, we do more than just read old books :^) Potential topics for your presentation might include geodata & geocomputation, network analysis, general graphing & plotting, time series analysis, an intro. to machine learning, sound analysis & sonification, using MMA with R-Link… etc. Martin (who is a data scientist for Oxford University IT Services, and previously worked as a consultant for Wolfram Research,([https://uk.linkedin.com/in/martinjohnhadley][4]) will be teaching the course. My research background is in the humanities (I’m digital project manager for [http://culturesofknowledge.org][5]) and I am still a WL beginner, so I'm collaborating with Martin to make our examples and data as relevant as possible to our predominantly 'newbie' humanities/social sciences audience. If you’re at all interested or curious to learn more, please let us know sooner rather than later, as we’d like to firm up the syllabus quite soon. We can host you for one or two nights in Oxford (including travel) if you’d like to give one presentation, or for as long as 5 days if you’d like to stay longer and give two talks (or perhaps even assist us with running the class itself). Although we didn’t plan this, this is a particularly auspicious time to be learning the WL for the first time, with lots of new resources newly available from WR and elsewhere, and huge potential for applying it in the humanities. [1]: https://uk.linkedin.com/in/martinjohnhadley [2]: http://digital.humanities.ox.ac.uk/dhoxss/2016 [3]: http://williamjturkel.net/digital-research-methods-with-mathematica [4]: https://uk.linkedin.com/in/martinjohnhadley [5]: http://culturesofknowledge.org Arno Bosse 2016-02-19T20:05:22Z