https://community.wolfram.com RSS Feed for Wolfram Community showing questions tagged with Computational Humanities sorted by most replies. 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/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/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 https://community.wolfram.com/groups/-/m/t/565816 I am collaborating in ethnomusicological research with a colleague who is blind and I want to generate graphics which can be printed on tactile paper, so that she can feel the graphics. In this context, I need to write text (e. g. in plot labels) in English Braille language. I can generate the Braille glyphs as graphics (see attached file), but I don´t know how to generate my own Braille font which could be used with any text such as the plot labels, etc. Help would highly be appreciated.... ![enter image description here][1] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2015-10-22_03-27-43.png&userId=11733 Frank Scherbaum 2015-09-16T05:52:02Z 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/841486 Hello, for a project in visual scene understanding I'm looking for a large corpus with parsed sentences from text (books, etc), from which I could extract Subject-Verb-Object (SVO) statistics. I would like to know for example frequencies of SVO triplets such as boy-play-girl in 'The boy in white is playing with the nice girl'. Thank you. Yair Lakretz 2016-04-18T13:57:28Z 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/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/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/813769 In this post I show how to create this [BubbleChart][1] representing the average words/minute and rating of the movie (the bigger the diameter of the bubble is, the better is the movie) and also show a simple way of building story flow visualization with [SmoothHistogram][2]. For the story flow you can take a look at this short tutorial [Story Flow in Alice][3] or even try coding it in a few lines in [**open cloud**][4]. ![enter image description here][5] ![enter image description here][6] Finally last Sunday [Leonardo DiCaprio][7] won his first Oscar with "The Revenant". He did many other great movies before, but the golden statuette always escaped from his hands. Here I will try to visualize his career trajectory by comparing his movies. In order to compare his movies I will use three variables for each movie: the year of its release, the average words/minute and its rating (taken from [IMDb][8]). The first thing that we need to do is to import the script of each movie (you can download the english subtitles in many sites). Let's import the ones for ["Inception"][9]: SetDirectory[NotebookDirectory[]]; srt = Import["inception-yify-english.srt", "Text"]; The format of the script is the following: "21 00:03:15,486 --> 00:03:18,447 Yes. In the dream state, your conscious defenses are lowered... 22 00:03:18,615 --> 00:03:21,033 ...and that makes your thoughts vulnerable to theft." So, we need to do some text processing in order to get a string with all words only: partitions = StringSplit[srt, "\n"]; blocks = Flatten[Position[StringSplit[srt, "\n"], ""]]; script = Flatten[Table[Table[i, {i, blocks[[j]] + 3, blocks[[j + 1]] - 1}], {j, Length[blocks] - 1}]]; stringsrt = StringDelete[StringJoin[Flatten[Map[partitions[[#]] &, script]]], {Shortest[ "[" ~~ x___ ~~ "]"]}]; Now, we can do for example a [WordCloud][10] of the movie: WordCloud[DeleteStopwords[stringsrt], ScalingFunctions -> (#^.1 &)] ![enter image description here][11] But what we actually want is the StringLength of the script, so we can estimate the average words/minute later on: StringLength[stringsrt] 68719 Repeating the same for the rest of the movies, we can finally create the [BubbleChart][12] that appears on top of the page: bubbleChart = Framed[Labeled[BubbleChart[<|"This Boy's Life 7.3" -> {1993, 45901/(4.79 115), 7.3}, "What's Eating Gilbert Grape 7.8" -> {1993, 45000/(4.79 118), 7.8}, "The Basketball Diaries 7.3" -> {1995, 45996/(4.79 102), 7.3}, "Total Eclipse 6.5" -> {1995, 29078/(4.79 111), 6.5}, "Romeo+Juliet 6.8" -> {1996, 41022/(4.79 120), 6.8}, "Titanic 7.7" -> {1997, 64681/(4.79 194), 7.7}, "The Man in the Iron Mask 6.4" -> {1998, 34450/(4.79 132), 6.4}, "The Beach 6.6" -> {2000, 42965/(4.79 119), 6.6}, "Gangs of New York 7.5" -> {2002, 53011/(4.79 167), 7.5}, "Catch Me If You Can 8.0" -> {2002, 62683/(4.79 141), 8.0}, "The Aviator 7.5" -> {2004, 83739/(4.79 170), 7.5}, "The Departed 8.5" -> {2006, 74151/(4.79 151), 8.5}, "Blood Diamond 8.0" -> {2006, 49529/(4.79 143), 8.0}, "Body of Lies 7.1" -> {2008, 58444/(4.79 128), 7.1}, "Revolutionary Road 7.3" -> {2008, 45111/(4.79 119), 7.3}, "Shutter Island 8.1" -> {2010, 55156/(4.79 138), 8.1}, "Inception 8.8" -> {2010, 61824/(4.79 148), 8.8}, "J. Edgar 6.6" -> {2011, 75697/(4.79 137), 6.6}, "The Revenant 8.2" -> {2016, 29250/(4.79 156), 8.2}, "Django Unchained 8.5" -> {2012, 68719/(4.79 165), 8.5}, "The Great Gatsby 7.3" -> {2013, 67586/(4.79 143), 7.3}, "The Wolf of Wall Street 8.2" -> {2013, 128803/(4.79 180), 8.2} |>, ChartLabels -> Automatic, ChartStyle -> {RGBColor[0.915, 0.3325, 0.2125, 0.89], RGBColor[ 1, 0.75, 0, 0.92], RGBColor[ 0.28026441037696703`, 0.715, 0.4292089322474965, 0.93], RGBColor[0.363898, 0.618501, 0.782349], RGBColor[ 0.40082222609352647`, 0.5220066643438841, 0.85, 0.92], RGBColor[ 0.528488, 0.470624, 0.701351, 0.9], RGBColor[1, 0.58, 0, 0.89], RGBColor[0.647624, 0.37816, 0.614037, 0.9400000000000001], RGBColor[0.40082222609352647`, 0.75, 0.85, 0.87], RGBColor[ 0.736782672705901, 0.358, 0.5030266573755369, 0.9400000000000001], RGBColor[ 0.8200000000000001, 0.09, 0.89, 0.81]}, PlotTheme -> "Detailed", ImageSize -> 1300, BubbleSizes -> {0.05, 0.3}, Background -> RGBColor[0.29, 0.29, 0.29, 0.97], FrameLabel -> {Style["Year", 24, Bold], Style["words / minute", 24, Bold]}, LabelStyle -> {RGBColor[0.93, 0.93, 0.93, 0.97], 14, FontFamily -> "Helvetica", Bold}], Style["Leonardo DiCaprio Movies", 30, RGBColor[1, 0.86, 0, 0.85], FontFamily -> "Helvetic", Bold], Top], FrameMargins -> 25, Background -> RGBColor[0.27, 0.27, 0.27, 0.97]] [1]: http://reference.wolfram.com/language/ref/BubbleChart.html [2]: http://reference.wolfram.com/language/ref/SmoothHistogram.html [3]: https://www.youtube.com/watch?v=IDr3iX7h6Qc [4]: https://www.wolfram.com/programming-lab/explorations/story-flow-in-alice/ [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Leo_DiCaprio.gif&userId=95400 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-03-02at9.04.02.png&userId=95400 [7]: https://www.wolframalpha.com/input/?i=leonardo%20dicaprio [8]: http://www.imdb.com/ [9]: https://www.wolframalpha.com/input/?i=inception&assumption=ClashPrefs_*Movie.Inception2010WarnerBrosPictures- [10]: https://reference.wolfram.com/language/ref/WordCloud.html [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-03-01at14.32.07.png&userId=95400 [12]: http://reference.wolfram.com/language/ref/BubbleChart.html Jofre Espigule-Pons 2016-03-01T12:41:56Z https://community.wolfram.com/groups/-/m/t/558518 I have recently visited [MoMa][1] (The Museum of Modern Art) in New York City, I always keep coming back there. To my surprise they have recently created an [official MoMa GitHub][2] account hosting data of their art collection, some basic metadata for each work, including title, artist, date made, medium, dimensions, and date acquired by the Museum. **How can we visualize and process MoMa data? What could we learn from this dataset? - please share your ideas** Below a simple stab at the topics of titles of the dataset. 1. Import data: moma = SemanticImport["https://raw.githubusercontent.com/MuseumofModernArt/collection/master/Artworks.csv"] ![enter image description here][3] 2. Get the titles colum: titles = Normal[moma[All, "Title"]]; 3. Make single string, DeleteStopwords, get TextWords and remove all words shorter than 4 characters. Build WoedCloud: str = StringJoin[titles]; words = TextWords[DeleteStopwords[str]]; filt = Select[words, StringLength[#] > 3 &]; WordCloud[filt] ![enter image description here][4] Hmmm.. I just have realized i can check who are most popular artists in the collection: artist = Normal[moma[[All, "Artist"]]]; WordCloud[artist] ![enter image description here][5] So the 8 top runners are: leads = Sort[Tally[artist], #1[[2]] < #2[[2]] &][[-8 ;;]]; leads // TableForm ![enter image description here][6] And now clouds about people in the cloud ;-) with WikipediaData (skipping unknown and blank): WordCloud[DeleteStopwords[WikipediaData[#]]] & /@ leads[[All, 1]][[{1, 2, 4, 6, 7, 8}]] ![enter image description here][7] Update due to Michael's comment below: -------------- Michael, thanks for the link. I really liked the idea of "modern" in MoMa. If this is a museum of "modern" art then it should modernize its collection pretty quickly moving with the step of time. In the dataset we infromation about dates of the creation (by artist) and acquisition (by MoMa) of the art. I got this visuals to inform us (points are creation-acquisition years pairs ): ![enter image description here][112] ![enter image description here][113] Now what are they and how to build them. But we will have to clean the data. Lets use regular import now: moma = Import["https://raw.githubusercontent.com/MuseumofModernArt/collection/master/Artworks.csv"]; The length of an entry is 14 Length@moma[[1]] `14` for exactly these categories: moma[[1]] // Column ![enter image description here][111] So out of moma // Length `137382` entries we keep only ones of the length 14 to avoid missing date entries: momaLE = Select[moma[[2 ;; -1]], Length[#] == 14 &]; momaLE // Length `112407` Now we get only columns 4 and 11 for creation and acquisition dates. And turn everything to strings: momaDaStr = ParallelMap[ToString, momaLE[[All, {4, 11}]], {2}]; so out of the form momaDaStr[[;; 6]] `{{"1896", "1996-04-09"}, {"1987", "1995-01-17"}, {"1903", "1997-01-15"}, {"1980", "1995-01-17"}, {"1903", "1997-01-15"}, {"1976-77", "1995-01-17"}}` it is easy just to grab first 4 characters of the year only (but first we have to get only those strings which are at least 4 characters): momaYear = Select[momaDaStr, StringLength[#[[1]]] > 3 && StringLength[#[[2]]] > 3 &]; yeye = ParallelMap[StringTake[#, 4] &, momaYear]; Now get only number-strings and turn them into numbers: numb = Select[yeye, StringMatchQ[#[[1]], NumberString] && StringMatchQ[#[[2]], NumberString] &]; pairs = ToExpression[ numb]; Alas we left with only: pairs // Length `86987` entries. Still a lot. Taking random sample of a few 1000s of entries makes a better visual: ListPlot[RandomSample[pairs, 5000], PlotTheme -> "Marketing", BaseStyle -> 15, PlotStyle -> Opacity[.3], AspectRatio -> Automatic] ![enter image description here][112] But perhaps we need to see where the most points are concentrated so we use smooth kernel distribution and indeed a lot of entries line up tight to the 1-to-1 correspondence between acquisition and creation dates, that's the slanted edge: Show[ SmoothDensityHistogram[#, PlotRangePadding -> 0, GridLines -> Automatic], Graphics[{Opacity[.7], Point[#]}], AspectRatio -> Automatic] &@RandomSample[pairs, 5000] ![enter image description here][113] We can compute average delay in acquisition - it is about 30 years: -Subtract @@@ pairs // Mean // N `27.53` What do we do next? [111]: /c/portal/getImageAttachment?filename=7463ScreenShot2015-09-02at7.29.31PM.png&userId=11733 [112]: /c/portal/getImageAttachment?filename=sdfq456thwrtafgewgf.png&userId=11733 [113]: /c/portal/getImageAttachment?filename=y56gq5465whrdfaqredgfhs.png&userId=11733 [1]: http://www.moma.org/ [2]: https://github.com/MuseumofModernArt [3]: /c/portal/getImageAttachment?filename=6683546trg6w5htregar.png&userId=11733 [4]: /c/portal/getImageAttachment?filename=4vb4qc56vecasdvshvgd.png&userId=11733 [5]: /c/portal/getImageAttachment?filename=sdf5trwhbdfsafbvfdf4rge.png&userId=11733 [6]: /c/portal/getImageAttachment?filename=ScreenShot2015-09-02at12.31.39PM.png&userId=11733 [7]: /c/portal/getImageAttachment?filename=fdsarteyhrsbdfC.png&userId=11733 Vitaliy Kaurov 2015-09-02T16:59:03Z 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/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/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/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/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/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/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