https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Computational Humanities sorted by most replies. https://community.wolfram.com/groups/-/m/t/2498984 > *SHARE this contest*: https://wolfr.am/CompArt-22 # WINNERS Thank you to everyone who submitted entries into this contest! It was a blast to see all the amazing art you created. After deliberation by our judges, these are the winners: - **Honorable Mention**: ARTIST: [Daniel Hoffmann][1], EXHIBIT: "[The Memory of Persistence][2]" - **Staff Winner**: ARTIST: [Anton Antonov][3], EXHIBIT: "[Rorschach mask animations projected over 3D surfaces][4]" - **3rd Place**: ARTIST: [Jacqueline Doan][5], EXHIBIT: "[Kuramoto oscillators with phase lag][6]" - **2nd Place**: ARTIST: [Tom Verhoeff][7], EXHIBIT: "[Sculpture from 18 congruent pieces][8]" - **1st Place**: ARTIST: [Frederick Wu][9], EXHIBIT: "[Love heart jewelry IV: the giving tree][10]" ![enter image description here][11] ---------- # CONTEST Flex your creative and computational skill with Wolfram's Computational Art Contest that kicks off today, Monday, March 28th! Share your work with the community, and potentially win free Wolfram merchandise. Programmers and artists of all skill levels are encouraged to participate! This contest is inspired by Genuary, an annual project releasing generative art prompts during the month of January. We're elated to see the creative works of our users and engage with the community while exploring the scope of computational art within the Wolfram Language. ## Rules & Guidelines ## - Submission deadline is April 25th at 9am Central Time. Posts posted after will not be included in judging - Participants must fill out a detailed Community profile ( example: https://community.wolfram.com/web/claytonshonkwiler ) and create a Community post about their submission. The post must include the code used to create graphics and the final piece of art placed at the top of the post. An explanation of how their code works is required, moreover participants are encouraged to write more about their creative process. - Participants submit their entry by commenting on this post with an image of their art, along with a link to their Community post - Multiple submissions per participant are allowed, but please keep the number of submissions under three - Each participant can only win once. Participants' best-performing piece, as determined by the judges, will be used when determining winners - Both static images and animations can be submitted. Animations are preferred in a GIF format; if the animation is too large for a GIF, the post can point to a public YouTube video. - Submissions will be judged by a handful of Wolfram experts, with the following parameters: - Visual aesthetics - Wolfram Language code - Creativity - Explanation of process - Submissions from all areas of computational art are welcome - Submissions from former or current Wolfram employees are allowed, but will be judged as their own category with only one winner - Submitting previous work/posts is allowed, but must meet the requirements stated above ## Encouragements ## - Not sure where to start? We encourage you to look at other user's submission for inspiration, or look at some of the work in the visual arts group of Community: - Artists' group: https://wolfr.am/ART-examples - Artist (see Staff Picks section): https://community.wolfram.com/web/claytonshonkwiler - We encourage you to vote and comment on other people's submissions. - Please spread the word about this competition, among your friends and other social media! ## Prizes ## First, second, and third place winners will be featured on all of Wolfram's social media accounts, as well as receiving their choice of free Wolfram merchandise. We are able to ship merchandise to countries listed on the Wolfram Store: https://store.wolfram.com. If your country is not listed on the Wolfram Store, we strongly encourage you to still submit an entry, as we will feature winners submissions regardless of location. ### Important ### All contest rules have been explained above under Rules & Guidelines. It's encouraged for all participants to read the rules carefully to prevent disqualification. If you have any additional questions, ask directly in the thread comments or contact us by email at t-artcontest@wolfram.com . We recommend reading other people comments as they clarify the nature of the contest as well. Comments deemed by moderators as superfluous to the thread may be removed or transferred by moderators to keep competition professional. [1]: https://community.wolfram.com/web/danielsanderhoffmann [2]: https://community.wolfram.com/groups/-/m/t/2518220 [3]: https://community.wolfram.com/web/antononcube [4]: https://community.wolfram.com/groups/-/m/t/2518279 [5]: https://community.wolfram.com/web/jacquelinengocdoan [6]: https://community.wolfram.com/groups/-/m/t/2509110 [7]: https://community.wolfram.com/web/tverhoeff [8]: https://community.wolfram.com/groups/-/m/t/2513265 [9]: https://community.wolfram.com/web/wufei1978 [10]: https://community.wolfram.com/groups/-/m/t/2430827 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=news-congrads-kkluyshnik-02-04-19.jpg&userId=11733 Eryn Gillam 2022-03-28T17:35:43Z https://community.wolfram.com/groups/-/m/t/1093926 ![enter image description here][16] # Introduction Back in [Wolfram Summer School 2016][1] I worked on the project "Image Transformation with Neural Networks: Real-Time Style Transfer and Super-Resolution", which got later [published on Wolfram Community][2]. At the time I had to use the MXNetLink package, but now all the needed functionality is built-in, so here is a top-level implementation of artistic style transfer with Wolfram Language. This is a slightly simplified version of the original method, as it uses a single VGG layer to extract the style features, but a full implementation is of course possible with minor modifications to the code. You can also find this example in the docs: [NetTrain][3] >> Applications >> Computer Vision >> Style Transfer # Code Create a new image with the content of a given image and in the style of another given image. This implementation follows the method described in Gatys et al., *A Neural Algorithm of Artistic Style*. An example content and style image: ![enter image description here][4] To create the image which is a mix of both of these images, start by obtaining a pre-trained image classification network: vggNet = NetModel["VGG-16 Trained on ImageNet Competition Data"]; Take a subnet that will be used as a feature extractor for the style and content images: featureNet = Take[vggNet, {1, "relu4_1"}] ![enter image description here][5] There are three loss functions used. The first loss ensures that the "content" is similar in the synthesized image and the content image: contentLoss = NetGraph[{MeanSquaredLossLayer[]}, {1 -> NetPort["LossContent"]}] ![enter image description here][6] The second loss ensures that the "style" is similar in the synthesized image and the style image. Style similarity is defined as the mean-squared difference between the Gram matrices of the input and target: gramMatrix = NetGraph[{FlattenLayer[-1], TransposeLayer[1 -> 2], DotLayer[]}, {1 -> 3, 1 -> 2 -> 3}]; styleLoss = NetGraph[{gramMatrix, gramMatrix, MeanSquaredLossLayer[]}, {NetPort["Input"] -> 1, NetPort["Target"] -> 2, {1, 2} -> 3, 3 -> NetPort["LossStyle"]}] ![enter image description here][7] The third loss ensures that the magnitude of intensity changes across adjacent pixels in the synthesized image is small. This helps the synthesized image look more natural: l2Loss = NetGraph[{ThreadingLayer[(#1 - #2)^2 &], SummationLayer[]}, {{NetPort["Input"], NetPort["Target"]} -> 1 -> 2}]; tvLoss = NetGraph[<| "dx1" -> PaddingLayer[{{0, 0}, {1, 0}, {0, 0}}, "Padding" -> "Fixed" ], "dx2" -> PaddingLayer[{{0, 0}, {0, 1}, {0, 0}}, "Padding" -> "Fixed"], "dy1" -> PaddingLayer[{{0, 0}, {0, 0}, {1, 0}}, "Padding" -> "Fixed" ], "dy2" -> PaddingLayer[{{0, 0}, {0, 0}, {0, 1}}, "Padding" -> "Fixed"], "lossx" -> l2Loss, "lossy" -> l2Loss, "tot" -> TotalLayer[]|>, {{"dx1", "dx2"} -> "lossx", {"dy1", "dy2"} -> "lossy", {"lossx", "lossy"} -> "tot" -> NetPort["LossTV"]}] ![enter image description here][8] Define a function that creates the final training net for any content and style image. This function also creates a random initial image: createTransferNet[net_, content_Image, styleFeatSize_] := Module[{dims = Prepend[3]@Reverse@ImageDimensions[content]}, NetGraph[<| "Image" -> ConstantArrayLayer["Array" -> RandomReal[{-0.1, 0.1}, dims]], "imageFeat" -> NetReplacePart[net, "Input" -> dims], "content" -> contentLoss, "style" -> styleLoss, "tv" -> tvLoss|>, {"Image" -> "imageFeat", {"imageFeat", NetPort["ContentFeature"]} -> "content", {"imageFeat", NetPort["StyleFeature"]} -> "style", "Image" -> "tv"}, "StyleFeature" -> styleFeatSize ] ] Define a [NetDecoder][9] for visualizing the predicted image: meanIm = NetExtract[featureNet, "Input"][["MeanImage"]] > {0.48502, 0.457957, 0.407604} decoder = NetDecoder[{"Image", "MeanImage" -> meanIm}] ![enter image description here][10] The training data consists of features extracted from the content and style images. Define a feature extraction function: extractFeatures[img_] := NetReplacePart[featureNet, "Input" ->NetEncoder[{"Image", ImageDimensions[img], "MeanImage" ->meanIm}]][img]; Create a training set consisting of a single example of a content and style feature: trainingdata = <| "ContentFeature" -> {extractFeatures[contentImg]}, "StyleFeature" -> {extractFeatures[styleImg]} |> Create the training net whose input dimensions correspond to the content and style image dimensions: net = createTransferNet[featureNet, contentImg, Dimensions@First@trainingdata["StyleFeature"]]; When training, the three losses are weighted differently to set the relative importance of the content and style. These values might need to be changed with different content and style images. Create a loss specification that defines the final loss as a combination of the three losses: perPixel = 1/(3*Apply[Times, ImageDimensions[contentImg]]); lossSpec = {"LossContent" -> Scaled[6.*10^-5], "LossStyle" -> Scaled[0.5*10^-14], "LossTV" -> Scaled[20.*perPixel]}; Optimize the image using [NetTrain][11]. [LearningRateMultipliers][12] are used to freeze all parameters in the net except for the [ConstantArrayLayer][13]. The training is best done on a GPU, as it will take up to an hour to get good results with CPU training. The training can be stopped at any time via Evaluation -> Abort Evaluation: trainedNet = NetTrain[net, trainingdata, lossSpec, LearningRateMultipliers -> {"Image" -> 1, _ -> None}, TrainingProgressReporting -> Function[decoder[#Weights[{"Image", "Array"}]]], MaxTrainingRounds -> 300, BatchSize -> 1, Method -> {"ADAM", "InitialLearningRate" -> 0.05}, TargetDevice -> "GPU" ] ![enter image description here][14] Extract the final image from the [ConstantArrayLayer][15] of the trained net: decoder[NetExtract[trainedNet, {"Image", "Array"}]] ![enter image description here][16] [1]: https://education.wolfram.com/summer/school/alumni/2016/salvarezza/ [2]: http://community.wolfram.com/groups/-/m/t/885941 [3]: http://reference.wolfram.com/language/ref/NetTrain.html [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=I_432.png&userId=95400 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=O_179.png&userId=95400 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=O_180.png&userId=95400 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=O_181.png&userId=95400 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=O_182.png&userId=95400 [9]: http://reference.wolfram.com/language/ref/NetDecoder.html [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=O_184.png&userId=95400 [11]: http://reference.wolfram.com/language/ref/NetTrain.html [12]: http://reference.wolfram.com/language/ref/LearningRateMultipliers.html [13]: http://reference.wolfram.com/language/ref/ConstantArrayLayer.html [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=O_185.png&userId=95400 [15]: http://reference.wolfram.com/language/ref/ConstantArrayLayer.html [16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=I_466.png&userId=95400 Matteo Salvarezza 2017-05-15T10:33:59Z https://community.wolfram.com/groups/-/m/t/1432072 *NOTE: This is a long page with many images. Scroll through to find some gems.* ---------- ![enter image description here][1] [WordFrequencyData][4] is a nifty instrument for mining oceans of texts and discovering wonderful historical semantic curiosities. **This post is a call for you to share your discoveries of interesting word histories**. Rules are very simple. - Post you discovery as a comment on this thread - Your discovery should be curious histories of some words that can be seen in their WordFrequencyData - Start your comment with a title clearly indicating the meaning of your discovery (use # as the first character to make a title) - Your comment must contain a plot WordFrequencyData of your terms. You can use the function I provide below. Alternatively you can use your own what to visualize WordFrequencyData. - Your comment must contain Wolfram Language code you use to make the plot - Your comment must contain some text explaining why you think the words you found are curious and interesting in your opinion - *If you want to comment on someone's work please click REPLY to his/her specific post so it is clear to what you refer and nested structure of comments is preserved.* Please see comment below for good examples. ---------- ### FUNCTION for PLOTs ---------- Feel free to use this function for your visualizations and change or improve it if you wish. Note what kind of options you can provide to this plot. I tried to limit those options to only very important once, fixing other options to make a nice plot. ClearAll@WordFrequencyPlot; Options[WordFrequencyPlot]= {"YearStart"->1800,"YearEnd"->Now,"Case"->True, "Smooth"->3,"Scaling"->None,"Style"->Automatic}; WordFrequencyPlot[words_,OptionsPattern[]]:= With[{ $data=WordFrequencyData[words,"TimeSeries", {OptionValue["YearStart"],OptionValue["YearEnd"]}, IgnoreCase->OptionValue["Case"]]}, DateListPlot[ MapThread[Callout, {MeanFilter[#,Quantity[OptionValue["Smooth"],"Years"]]&/@ Values[$data],words}], ScalingFunctions->OptionValue["Scaling"], PlotRange->All, PlotTheme->"Detailed", PlotStyle->OptionValue["Style"], FrameTicks->{Automatic,None}, ImageSize->Large, FrameLabel->{"YEAR","FREQUENCY in TEXT"}] ] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-09-04at5.02.04PM.png&userId=11733 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-08-30at8.19.02PM.png&userId=20103 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-09-04at12.48.22PM.png&userId=11733 [4]: http://reference.wolfram.com/language/ref/WordFrequencyData.html Vitaliy Kaurov 2018-08-30T21:41:25Z https://community.wolfram.com/groups/-/m/t/2445356 ![enter image description here][1] The popular game Wordle can take up a lot of your time. The author designed it so that it you can only play it once a day, thus saving us from ourselves :-). [Wordle][2] [NYTimes article on Wordle][3] But I couldn't resist the challenge to create a version of it in Mathematica, just for fun and because I was bored this past weekend. See the attached notebook and enjoy. Alas, since you can run it any number of times you are only to blame for yourself it you spend too much time on it. After executing the notebook just execute MWordle[Deploy] to bring up the game. A few additional comments. The notebook MWordle.nb has the option AutoGeneratedPackage -> Automatic which causes it, when saved, to create an MWordle.m package file in its same directory. The code in MWordle.nb is set up as a package with the context MWordle`Mwordle` If you want to set things up so that the package gets loaded and the MWordle game is automatically launched, do the following. Create a directory MWordleGame on your disk (The name MWordleGame can actually be whatever you wish.) And in the MWordleGame directory create a new directory called MWordle. (This name must be exactly that so that the MWordle`Mwordle` Context is property respected.) Put the MWordle.nb notebook in the MWordle dierectory, open it in Mathematica and save it so that the MWordle.m file is created in the MWordle directory. Then you can close the MWordle.nb notebook. Now in your MWordleGame directory save a new notebook -- you can call it whatever you wish, but something like LaunchMwordle.nb is a sensible choice. In that notebook create a button with the following command: CellPrint[TextCell[Button["Launch MWordle", Monitor[ If[! MemberQ[$Path, NotebookDirectory[]], AppendTo[$Path, NotebookDirectory[]]]; Needs["MWordle`MWordle`"]; MWordle`MWordle`MWordle[Deploy], Row[{ProgressIndicator[Appearance -> "Necklace", ImageSize -> Small], Spacer[5], Style["Launching MWordle...", 12, Blue, FontFamily -> "Arial"]}]], Method -> "Queued"], "Text", GeneratedCell -> False, CellAutoOverwrite -> False]] You now have a button in your LaunchMwordle.nb notebook which you can use any time you want to launch MWordle without having to execute the cells in the MWordle.nb notebook. Download the actual notebook from the link at the end of this post. The following is a version here to read. &[Wolfram Notebook][4] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Wordle.gif&userId=20103 [2]: https://www.powerlanguage.co.uk/wordle/ [3]: https://www.nytimes.com/2022/01/03/technology/wordle-word-game-creator.html [4]: https://www.wolframcloud.com/obj/08c015e2-0d65-4634-bf54-4b73e518f6d5 David Reiss 2022-01-13T21:47:44Z https://community.wolfram.com/groups/-/m/t/1677058 This is the first part of an ongoing series. The second part can be found [here][1]. Poets pay attention to the natural stresses in words, and sometimes they arrange words so that the stresses form patterns. Typical patterns stress every other syllable (duple meter) or every third syllable (triple meter). Conventions exist to further classify poetic lines according to a unit of two or three syllables, called a *foot*. I choose not to follow this convention, instead looking at the line of poetry as a continuous pattern. The goal of step 1 is to display the pattern of a line of poetry graphically around the printed syllables . The function below accepts a line of English poetry (or prose) and returns the stress pattern with syllables. It gets the stress information from the "PhoneticForm" property in WordData and the syllabification information from the "Hyphenation" property. Sometimes words are not in WordData, or the database doesn't have phonetic or hyphenation values for the word. Much of the code deals with how to guess at those values when they are missing. Also, 1-syllable words are stressed in the database, but stopwords are usually unstressed in context. So the code demotes single-syllable stopwords from stressed to undetermined. A series of replacement rules attempts to resolve syllables that the program has not yet determined to be stressed or unstressed. analyzeMeter[verse_] := { ipaVowels = {"a?", "a?", "e?", "??", "o?", "?", "?", "?", "?", "?", "?", "?", "?", "?", "?", "?", "?", "?", "?", "?", "?", "?", "?", "?", "?", "a", "æ", "e", "i", "o", "œ", "ø", "u", "y"}; words = ToLowerCase[TextWords[verse]]; getWordInfo[wd_] := { ipa = WordData[wd, "PhoneticForm"]; str = If[StringQ[ipa], vow = StringCases[ipa, "?" | "?" ... ~~ ipaVowels]; ToExpression[ StringReplace[ vow, {"?" ~~ __ -> "1", "?" ~~ __ -> ".5", __ -> "0"}]], dips = {"ae", "ai", "au", "ay", "ea", "ee", "ei", "eu", "ey", "ie", "oa", "oe", "oi", "oo", "ou", "oy", "ue", "ui", "uy"}; vows = {"a", "e", "i", "o", "u", "y"}; Table[.5, Total[ToExpression[ Characters[ StringReplace[ wd, {StartOfString ~~ "y" -> "0", "e" ~~ EndOfString -> "0", dips -> "1", vows -> "1", _ -> "0"}]]]]]]; hyp = WordData[wd, "Hyphenation"]; fauxSyl = StringPartition[wd, UpTo[Ceiling[StringLength[wd]/Length[str]]]]; syl = If[ListQ[hyp] && Length[hyp] == Length[fauxSyl], hyp, fauxSyl]; {wd, str, syl}}; wordInfo = getWordInfo[#][[1]] & /@ words; stops1IPA = Select[DeleteMissing[ WordData[#, "PhoneticForm"] & /@ WordData[All, "Stopwords"]], StringCount[#, ipaVowels] < 2 &]; wordInfo = wordInfo /. {a_, b_List, c_} /; MemberQ[stops1IPA, WordData[a, "PhoneticForm"]] -> {a, {.5}, c}; wordInfo = wordInfo /. {a_, b_List, c_} /; ! MemberQ[stops1IPA, WordData[a, "PhoneticForm"]] && b == {.5} -> {a, {1}, c}; preMeter = wordInfo[[;; , 2]] // Flatten; meter = preMeter //. { {a___, .5, 1, 1, b___} -> {a, 0, 1, 1, b}, {a___, 1, 1, .5, b___} -> {a, 1, 1, 0, b}, {a___, 1, .5, 1, b___} -> {a, 1, 0, 1, b}, {a___, 0, .5, 0, b___} -> {a, 0, 1, 0, b}, {a___, .5, 1, b___} -> {a, 0, 1, b}, {a___, 1, .5, b___} -> {a, 1, 0, b}, {a___, 0, .5} -> {a, 0, 1}, {.5, 0, b___} -> {1, 0, b}, {a___, .5, 0, 1, 0, 1, b___} -> {a, 1, 0, 1, 0, 1, b}, {a___, .5, 1, 0, 1, 0, b___} -> {a, 0, 1, 0, 1, 0, b}, {a___, .5, 0, 0, 1, 0, 0, 1, b___} -> {a, 1, 0, 0, 1, 0, 0, 1, b}, {a___, 1, 0, 1, 0, .5, b___} -> {a, 1, 0, 1, 0, 1, b}, {a___, 0, 1, 0, 1, .5, b___} -> {a, 0, 1, 0, 1, 0, b}, {a___, 1, 0, 0, 1, 0, 0, .5, b___} -> {a, 1, 0, 0, 1, 0, 0, 1, b}, {a___, .5, .5, .5} -> {a, 0, 1, 0}, {.5, .5, b___} -> {1, 0, b}}; coords = Partition[Riffle[Range[Length[meter]], meter], 2]; syllab = Flatten[wordInfo[[;; , 3]]]; visual = Graphics[{Line[coords], MapIndexed[ Style[Text[#1, {#2[[1]], .5}], 15, FontFamily -> "Times"] &, syllab]}, ImageMargins -> {{10, 10}, {0, 0}}, ImageSize -> 48*Length[meter]] }; analyzeMeter["Once upon a midnight dreary, while I pondered, weak and \ weary,"] ![enter image description here][2] Thanks to Edgar Allan Poe for his poem "The Raven." The zigzag line zigs up for stressed syllables and down for unstressed. The program analyzes this verse without error or deviation from the expected meter. However, poets don't always follow the expected pattern, and the program occasional makes mistakes. Consider the program's output for the entire second stanza of "The Raven." ![enter image description here][3] The graphic makes it easy to see deviations from the pattern. In the second line of this stanza, the program mistakenly considers "separate" to have three syllables as if it were a verb. However, when "separate" is used as an adjective, as in "separate dying ember," it only has two syllables. In the third verse, the last syllable of "eagerly" is so weak that the program marks it as unstressed. This is a reasonable and arguably correct way to assess the syllable, though traditionally it should be marked as stressed. The fifth verse also has an anomaly. Poe has added an extra syllable to the line with the word "radiant." As an English teacher, I think this visual gives insight into such subtle poetic notions as elision, secondary stress, and masculine/feminine rhyme. A possible activity is for students to use the program to analyze the prevailing pattern in a stanza of poetry and then explain the variations from that pattern as nuances of the language (as in "eagerly"), deliberate deviations by the poet (as in "radiant"), or mistakes by the program (as in "separate"). "The Raven" follows a duple meter pattern of alternating stressed and unstressed syllables. The program can also handle poems that follow the other major metrical pattern, triple meter. Here are verses from "Evangeline" by Henry Wadsworth Longfellow and "'Twas the Night Before Christmas" by Clement Clarke Moore. ![enter image description here][4] One would expect that the program would show free verse and prose as having no recognizable metrical pattern. Let's see. Here are two lines of Walt Whitman's free verse poem "When I Heard the Learn'd Astronomer": ![enter image description here][5] And here is a sentence from the Wikipedia article on butterflies. ![enter image description here][6] The traditional way to teach meter in poetry is to explain about iambs, trochees, etc. and then have students try to mark lines of poetry with those units. Students, who may be distinguishing stressed syllables for the first time are hard pressed to find metrical feet in a verse. With this program, a student has a starting point to explore, analyze, interpret, and critique. It's like using Wolfram Alpha to understand the graph of a rational function rather than trying to sketch it yourself following the rules the teacher lectured about. I would call the program a work in progress rather than a success. If you experiment with poems of your choice, you'll find that it sometimes fails to resolve a syllable, leaving it stuck halfway between stressed and unstressed. Also, if it misinterprets a syllable, marking it stressed, for instance, when it shouldn't be, the error can spread to neighboring syllables and corrupt the interpretation of the whole line. It works more consistently with duple meter than triple meter. Twice I tried to improve the program with machine learning. I thought that if machine learning could classify the unresolved pattern as either duple meter, triple meter, or neither, then the program could better resolve the undetermined syllables. I was encouraged when it had 99% confidence that lines from "The Raven" were duple meter, but then I realized it was just as certain that any input was duple meter. My second attempt was to make a neural net that accepted a word and returned a likely stress pattern. For instance, I would feed it "Lenore" and it would return {0,1}. I think this should be doable, training it on data from WordData, but I am not strong enough in machine learning to make it happen (yet). I subtitled this "Part 1," which implies that there is more to come. I intend to follow this with a program that makes rhyme visible, including alliteration, assonance, and other sound features loosely associated with rhyme. Thanks for sticking with this to the end, Mark Greenberg [1]: https://community.wolfram.com/groups/-/m/t/1728031 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=rav11.png&userId=788861 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-05-06at5.05.53PM.png&userId=788861 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-05-06at5.08.16PM.png&userId=788861 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-05-06at5.10.17PM.png&userId=788861 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=wik1.png&userId=788861 Mark Greenberg 2019-05-07T00:14:16Z https://community.wolfram.com/groups/-/m/t/1727272 Introduction ---------- A couple of days ago on 1 July [The Economist][1] tweeted [this][2]: > Since he was elected in 2016 Donald Trump has made 1,384 mentions of foreign countries on Twitter. Can you guess which one he named most often? [It claims][3] that in spite of the "special relationship" with the UK, it is only ranked 15th of the countries and territories tweeted about. It also says that Puerto Rico, Mexico and China are in fifth, fourth and third places respectively (countries and territories). According to The Economist North Korea is ranked in second place with 163 mentions. A couple of years ago I read the excellent book "A Mathematician Reads the Newspaper" by John Allen Paulos; and I wonder how much of the daily news coverage can we check using the Wolfram Language. *In a future post I will speak about another project that we are doing with several members of this community that goes in a similar direction. We call it "computational conversations". With a bit of luck you might hear about it at the [Wolfram Technology Conference][4] later this year.* Initial analysis ---------- It turns out that I have been monitoring @realDonaldTrump's tweets using IFTTT since early 2017. I attach excel files to this post. To have a look at the first tweet we first set the directory and load the raw data files: SetDirectory[NotebookDirectory[]] dataraw = Import /@ FileNames["Trump*.xlsx"]; As the first file (without a number) will be read in last (alphabetical order), this is the first tweet data: dataraw[[5, 1, 1]] // TableForm ![enter image description here][5] It is from January 26th, 2017, a couple of days after his inauguration. In oder to figure out which countries Mr Trump talks about we use the function TextCases, a recently updated function: tweettexts = Join[dataraw[[1, 1]], dataraw[[2, 1]], dataraw[[3, 1]], dataraw[[4, 1]], dataraw[[5, 1]]][[All, 2]]; locations = TextCases[StringJoin[tweettexts], "LocationEntity" -> "Interpretation", VerifyInterpretation -> True]; I find Length@locations 5768 locations; these will not only include direct mentions of countries but also locations within countries. These locations will be in Entity-form: locations[[1;;20]] ![enter image description here][6] Let's get that apart. First we make a list of all countries in the world: purecountries = # -> {#} & /@ EntityList[EntityClass["Country", "Countries"]]; If we select all direct mentions of countries we obtain: Select[locations, MemberQ[purecountries[[All, 1]], #] &] // Length 3624 mentions; if we exclude the 1349 mentions the US, we are left with 2275 country names. Despite our list starting with later tweets we obtain substantially more mentions of countries than The Economist (1,384). We can now generate a table of the mentions of all countries: TableForm[Flatten /@ Transpose[{Range[Length[#] - 1], Delete[#, 5]}] &@({#[[1]], #[[2]]} & /@ Normal[ReverseSort[Counts[CommonName@(Select[locations, MemberQ[purecountries[[All, 1]], #] &])]]])] ![enter image description here][7] (This is only the top of the list.) Note, that North Korea is missing, but will be very prominent in the next table.... Next we can check for "indirect" mentions of a country, i.e. Louvre would lead to a mention of France etc. We will find many more entities and will first generate a list of substitution rules: countriesrules = # -> Check[GeoIdentify["Country", #], {#}] & /@ (Complement[DeleteDuplicates[locations], EntityList[EntityClass["Country", "Countries"]]]); We will ignore the error messages for now. We can then generate a table that includes the "indirect" mentions, too: TableForm[Flatten /@ Transpose[{Range[Length[#] - 1], Delete[#, 5]}] &@({#[[1]], #[[2]]} & /@ Normal[ReverseSort[Counts[CommonName@(DeleteMissing[Flatten[locations /. countriesrules]])]]])] ![enter image description here][8] Note, that on rank 4 we find Media, which is not a country. It is easy to clean out, but I leave it in to show the performance of the code so far. We could now make typical representations such as GeoBubbleCharts: GeoBubbleChart[Counts[DeleteMissing[Flatten[locations /. countriesrules]]], GeoBackground -> "Satellite"] ![enter image description here][9] We can now make a BarChart (on a logarithmic scale) selecting "purecountries" like so: BarChart[ReverseSort@<| Select[Normal@ Counts[DeleteMissing[Flatten[locations /. countriesrules]]], MemberQ[purecountries[[All, 1]], #[[1]]] &]|>, ScalingFunctions -> "Log", ChartLabels -> (Rotate[#, Pi/2] & /@ CommonName[ ReverseSortBy[ Select[Normal@ Counts[DeleteMissing[Flatten[locations /. countriesrules]]], MemberQ[purecountries[[All, 1]], #[[1]]] &], Last][[All, 1]]]), PlotTheme -> "Marketing", LabelStyle -> Directive[Bold, 15]] ![enter image description here][10] We can also represent that on a world wide map: styling = {GeoBackground -> GeoStyling["StreetMapNoLabels", GeoStylingImageFunction -> (ImageAdjust@ColorNegate@ColorConvert[#1, "Grayscale"] &)], GeoScaleBar -> Placed[{"Metric", "Imperial"}, {Right, Bottom}], GeoRangePadding -> Full, ImageSize -> Large}; GeoRegionValuePlot[ Log@<|Select[Normal@Counts[DeleteMissing[Flatten[locations /. countriesrules]]], MemberQ[purecountries[[All, 1]], #[[1]]] &]|>, Join[styling, {ColorFunction -> "TemperatureMap"}]] ![enter image description here][11] Further analysis ---------- We can of course look at many other features of the tweets. One is a simple sentiment analysis. I am not at all convinced that the result of this attempt are useful or representing an actual pattern. But this is what we could do: emotion[text_] := "Positive" - "Negative" /. Classify["Sentiment", text, "Probabilities"] and then tweetssentiments = emotion /@ tweettexts; ListPlot[tweetssentiments, PlotRange -> All, LabelStyle -> Directive[Bold, 15], AxesLabel -> {"tweet number", "sentiment"}] ![enter image description here][12] Using a SmoothHistogram, we see a pattern of "extremes", negative, neutral, positive: SmoothHistogram[tweetssentiments, PlotTheme -> "Marketing", FrameLabel -> {"sentiment", "probablitiy"}, LabelStyle -> Directive[Bold, 16], ImageSize -> Large] ![enter image description here][13] We can also ask for less relevant information, such as the colours mentioned in the tweets: textcasesColor = TextCases[StringJoin[tweettexts], "Color" -> "Interpretation", VerifyInterpretation -> True] ![enter image description here][14] So there is a lot of white, some black, red and green: ReverseSort@Counts[textcasesColor] ![enter image description here][15] Let's blend these colours together: Graphics[{Blend[textcasesColor], Disk[]}] ![enter image description here][16] We can also look for "profanity" in tweets: textcasesProfanity = TextCases[StringJoin[tweettexts], "Profanity"]; and represent these tweets in a table: Column[textcasesProfanity, Frame -> All] ![enter image description here][17] It is not quite clear to my why some of the tweets are classified as containing profanity. For some tweets it is relatively obvious, I think. Twitter handles ---------- Another interesting analysis is to look at the twitter handles that @realDonaldTrump uses: textcasesTwitterHandle = TextCases[StringJoin[tweettexts], "TwitterHandle"]; Here are counts of the 50 most common handles: twitterhandles50 = Normal[(ReverseSort@Counts[ToLowerCase /@ textcasesTwitterHandle])[[1 ;; 50]]] ![enter image description here][18] Last but not least we can make a BarChart of that: BarChart[<|twitterhandles50|>, ChartLabels -> (Rotate[#, Pi/2] & /@ twitterhandles50[[All, 1]]), LabelStyle -> Directive[Bold, 14]] ![enter image description here][19] and to compare the same on a logarithmic scale: BarChart[<|twitterhandles50|>, ChartLabels -> (Rotate[#, Pi/2] & /@ twitterhandles50[[All, 1]]), LabelStyle -> Directive[Bold, 14], ScalingFunctions -> "Log"] ![enter image description here][20] A little word cloud ---------- Just to finish off we will generate a little word cloud like so: allwords = Flatten[TextWords /@ tweettexts]; WordCloud[ToLowerCase /@ DeleteCases[DeleteStopwords[ToString /@ allwords], "&"]] ![enter image description here][21] The cloud picks up on "witch hunt" and "collusion", "@foxandfrieds" and "Russia", "fake", "border" as well as other terms that indeed are relatively prominent in the media. Conclusion ---------- The main objective of this was to look try to reproduce at least qualitatively the results of the twitter analysis of @realDonaldTrump's tweets by The Economist using the Wolfram Language. We have been using a slightly different period of the tweets. We have been looking at direct mentions and "indirect" ones. I have not made any manual comparison of the results. I am not sure whether the recognition has worked and I only post it as a first cursory analysis. It was relatively easy to go beyond the analysis and look at other features of the tweets, too. [1]: https://www.economist.com [2]: https://twitter.com/TheEconomist/status/1145467208950329344 [3]: https://www.economist.com/graphic-detail/2019/06/04/the-world-according-to-donald-trump [4]: http://www.wolfram.com/events/technology-conference/2019/ [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1000.12.59.png&userId=48754 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1000.27.41.png&userId=48754 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1000.34.11.png&userId=48754 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1000.41.34.png&userId=48754 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1000.43.14.png&userId=48754 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1000.45.38.png&userId=48754 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1001.24.25.png&userId=48754 [12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1000.53.33.png&userId=48754 [13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1000.55.22.png&userId=48754 [14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1001.05.39.png&userId=48754 [15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1001.07.12.png&userId=48754 [16]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1001.08.07.png&userId=48754 [17]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1001.09.33.png&userId=48754 [18]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1001.12.15.png&userId=48754 [19]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1001.13.26.png&userId=48754 [20]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1001.14.50.png&userId=48754 [21]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2019-07-1001.33.04.png&userId=48754 Marco Thiel 2019-07-10T00:40:42Z https://community.wolfram.com/groups/-/m/t/932548 #Introduction I recently saw a TV show set at Four Corners USA, the point where Utah, Colorado, Arizona, and New Mexico meet: ![enter image description here][1] It made me wonder how frequent 4 or more geographical borders meet at one point. According to [Wikipedia][2], 4 borders meeting at a point is called a ***quadripoint***, 5 borders meeting is called a ***quintipoint***, and in general it's called a ***multipoint***. The entry only lists one quintipoint and goes on to say > Perhaps a dozen quintipoints of various levels of geopolitical subdivisions are scattered around the world; This piqued my interest to find all multipoints, using the Wolfram Language. -------- #Results Before I give the details on how to detect multipoints, I'd like to showcase the results. ###Summary - Since borders are not always precise (or even well defined at times), I allowed for an error up to ~100 meters when classifying points. - The polygons were obtained from the `"Country"` and `"AdministrativeDivision"` `Entity` types (about 40,000 in total). - There are a total of **724 quadripoints** in this dataset. - There are a total of **13 quintipoints** in this dataset. - There is **1 *10-point*** in this dataset! - There are **only 6 multipoints** in the dataset whose regions *don't* share the same parent region. ###Quadripoints With **724 quadripoints**, there are too many to list here, but here are a few interesting ones. - The only countries to form a quadripoint are **Namibia, Botswana, Zambia, and Zimbabwe**. ![enter image description here][3] - There are a considerable amount of **counties in Iowa and Texas** that are apart of multiple quadripoints, i.e. more than one corner is a quadripoint. This is because they are roughly arranged in a rectangular grid. ![enter image description here][4] - There were only 6 quadripoints found whose parent regions differ: ![enter image description here][5] - Here's a visual summary of all quadripoints found (note the level 3 regions were heavily thickened to become visible): ![enter image description here][6] ###Quintipoints Here are all **13 quintipoints** found: - **Saint Kitts and Nevis**: Saint George Gingerland - Saint James Windward - Saint John Figtree - Saint Paul Charlestown - Saint Thomas Lowland - **Boyaca, Colombia**: Chinavita - Garagoa - Miraflores - Ramiriquí - Zetaquirá - **Counties in Florida, USA**: Glades - Hendry - Martin - Okeechobee - Palm Beach - **Usulutan, El Salvador**: California - Ozatlán - Santa Elena - Tecapán - Usulután - **Arequipa, Arequipa, Peru**: Alto Selva Alegre - Cayma - Chiguata - Miraflores - San Juan de Tarucani - **Cuenca, Azuay, Ecuador**: Chiquintad - Cuenca - Ricaurte - Sidcay - Sinicay - **Pea Reang, Prey Vêng, Cambodia**: Kampong Popil - Mesa Prachan - Prey Sralet - Reab - Roka - **Rieti, Lazio, Italy**: Borgo Velino - Castel Sant' Angelo - Cittaducale - Micigliano - Rieti - **Cosenza, Calabria, Italy**: Marano Marchesato - Marano Principato - Rende - San Fili - San Lucido - **Napoli, Campania, Italy**: Boscotrecase - Ercolano - Ottaviano - Torre Del Greco - Trecase - **Savona, Liguria, Italy**: Bardineto - Boissano - Giustenice - Loano - Pietra Ligure - **Torino, Piemonte, Italy**: Cuceglio - Mercenasco - Montalenghe - Scarmagno - Vialfrè - **Viterbo, Lazio, Italy**: Bolsena - Capodimonte - Gradoli - Montefiascone - San Lorenzo Nuovo As you can see, Italy takes the cake with 6 quintipoints! Here's a visual of these quintipoints, along with the error allowing them to be classified as such: ![enter image description here][7] ###A Near 6-point Notice in the top right map above, it looks like there is room for one more region in Viterbo, Lazio, Italy, which would make it a 6-point. Here's the 6th region (Grotte Di Castro) in black: ![enter image description here][8] It turns out Grotte Di Castro is about 700 meters from the quintipoint, making this only a ***near* 6-point**: ![enter image description here][9] ###10-point As mentioned in the [Wikipedia entry][10], there is a 10-point in Italy at the summit of [Mount Etna][11]: - **Catania, Sicily, Italy**: Adrano - Belpasso - Biancavilla - Bronte - Castiglione Di Sicilia - Maletto - Nicolosi - Randazzo - Sant' Alfio - Zafferana Etnea ![enter image description here][12] ###Allowing for more error If we allow for more error, we can find ***near-multipoints*** - regions that almost have a multipoint, but clearly don't. For example, there is a near-quintipoint in Texas, USA: ![enter image description here][13] -------- #Code The idea to find multipoints within a collection of regions is as follows: 1. Obtain the `Polygon` for each region. 2. For each pair of regions, if there's a vertex from one of the polygons which is "close" to the other, mark these regions as touching. `RegionDistance` can be used for this. 3. The relation of touching between pairs forms an adjacency matrix. From this, form a `Graph` and use `FindClique` to find all multipoints in this collection. Here is code that does just that: discretize[Polygon[pts_?MatrixQ]] := MeshRegion[pts, Polygon[Range[Length[pts]]]] discretize[Polygon[pts_?(VectorQ[#, MatrixQ] &)]] := With[{pts2 = Select[pts, Length[#] > 2 &]}, MeshRegion[Join @@ pts2, Polygon[Range[# + 1, #2] & @@@ Partition[Prepend[Accumulate[Map[Length, pts2]], 0], 2, 1]]] ] discretize[expr_] := With[{mr = DiscretizeGraphics[Graphics[expr]]}, mr /; MeshRegionQ[mr] ] discretize[_] = $Failed; polyLookup = discretize /@ (Join[ EntityValue["Country", "Polygon", "EntityAssociation"], EntityValue["AdministrativeDivision", "Polygon", "EntityAssociation"] ] /. GeoPosition -> Identity); MultiPoints[divs_List, n_] /; Length[divs] < n = {}; MultiPoints[divs_List, n_] := Block[{polys, disj, cands}, polys = polyLookup /@ divs; ( disj = Boole[Outer[CoordinateNear, polys, polys]] - IdentityMatrix[Length[divs]]; ( cands = FindClique[AdjacencyGraph[divs, disj], {n, Infinity}, All]; resolveMultiPoints[cands, AssociationThread[divs, polys]] ) /; MatrixQ[disj, IntegerQ] ) /; VectorQ[polys, MeshRegionQ] ] MultiPoints[___] = {}; $tol = 0.001; CoordinateNear[mr1_, mr2_, tol_:$tol] := With[{d = {{-tol, tol}, {-tol, tol}}}, And[ NoneTrue[Transpose[{d+RegionBounds[mr1], d+RegionBounds[mr2]}], #1[[2,1]] > #1[[1,2]] || #1[[1,1]] > #1[[2,2]]&], Min[RegionDistance[mr1, MeshCoordinates[mr2]]] < tol ] ] resolveMultiPoints[{}, _] = {}; resolveMultiPoints[cands_List, passoc_?AssociationQ] := Select[cands, MultiPointQ[#, passoc]&] MultiPointQ[cands_, passoc_?AssociationQ, tol_:$tol] := Block[{coords, mrs}, mrs = passoc /@ cands; coords = Union @@ MeshCoordinates /@ mrs; Or @@ Thread[And @@ (Thread[RegionDistance[#, coords] < tol]& /@ mrs)] ] Now here's all multipoints formed from countries: ![enter image description here][14] Now to explore all cases, we can start off by looking for multipoints in all subdivisions of a given region, e.g. given Florida, find all multipoints within the counties of Florida. This can be achieved by building a hierarchical graph connecting countries and administrative divisions. Then for a given region, this graph can be used to find all subdivisions and the above code can be used to find the multipoints. ad = AdministrativeDivisionData[]; pr = EntityValue["AdministrativeDivision", "ParentRegion"]; $ADNetwork = Graph[Join[ Thread["NullPointer" -> EntityList["Country"]], DeleteCases[Thread[pr -> ad], Rule[_Missing, _]] ]]; ChildrenMultiPoints[reg_] := ChildrenMultiPoints[reg, 4] ChildrenMultiPoints[reg_, o___] := MultiPoints[Rest[VertexOutComponent[$ADNetwork, reg, 1]], o] ![enter image description here][15] Lastly, to cover all cases we need to consider sets of regions that have differing parent regions. To do this, for a given parent region $P$, first find all other regions $R_i$ (on the same level) that touch this region. Then simply run `MultiPoints` on all subdivisions in $P \cup R_i$. I omit this code here, as there were only 6 instances that came out of this case. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=7535fourcorners.png&userId=46025 [2]: https://en.wikipedia.org/wiki/Quadripoint [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=countryquadripoint.png&userId=46025 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2008squarequadripoints.png&userId=46025 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=crossregionquadripoints.png&userId=46025 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=allquadripoints.png&userId=46025 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4697quintipoints.png&userId=46025 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=8873almostsixpoint.png&userId=46025 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=9086almostsixpointzoom.png&userId=46025 [10]: https://en.wikipedia.org/wiki/Quadripoint#Multipoints_of_greater_numerical_complexity [11]: https://en.wikipedia.org/wiki/Mount_Etna#Geopolitical_oddity [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3719tenpoint.png&userId=46025 [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4645almostquintpoint.png&userId=46025 [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2016-10-0117.18.37.png&userId=46025 [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2016-10-0117.27.16.png&userId=46025 Greg Hurst 2016-10-01T22:56:22Z https://community.wolfram.com/groups/-/m/t/2135869 Introduction ------------ The goal of this post is to start from images like this example one : ![Girl3][1] and generate pictures like: ![Girl3Gray][2] or ![Girl3Color][3] Mathematica at least 12.1 will be required since Mixed Integer programming is used. Explanation ----------- Let's take the first image (black and white) as an example. Let's assume we have a collection of 16 tiles: ![GrayTiles][4] The problem to solve is how to place the tiles on the picture so that the gray content of a tile is close to the gray content of the picture below it and at the same time the topological constraints are satisfied. By topological constraints, I mean that the tiles must be compatible. This is allowed: ![Allowed][5] This is forbidden because the dark horizontal band is continuing as a white horizontal band. ![Forbidden][6] We are going to translate this problem into a set of equations on integer variables and with a linear cost function to optimize. The final problem will be solved with the LinearOptimization function from Mathematica 12.1. Each pixel of the image is encoded by a vector ![eq1][7] because there are 16 different tiles in this example. The components of the vector can be either 0 or 1. This is expressed as: VectorLessEqual[{0, v}], VectorLessEqual[{v, 1}], v \[Element] Vectors[nbTiles, Integers] For each pixel, only one tile can be used. We cannot put several tiles on a pixel but only choose one and only one. If we use the constraint: ![eq2][8] then we express that only one tile can be used. Indeed, since the component are integers and equal to 0 or 1, then the only way to satisfy this equation is that one of the components, and only one, is equal to one. Expressing the topological constraints is similar. We have equations like: ![eq3][9] This equation is describing a relationship between pixel (x,y) and pixel (x+1,y). The values on left and right side can either be 0 or 1 (at same time). When zero it means : none of the tiles is used. When one, it means one of the tile is used. So, the translation of the equation is: If the tile 0,3 or 5 are used at pixel (x,y) then the tiles 3,6,9 or 11 must be used at pixel (x+1,y). (I have not checked if it makes sense with the set of tiles I am using as example. The constraints for those tiles are probably different.). To describe the topological constraint of the tiles, we have functions like: rightSide[tileA[{a_,b_,c_}]] :={b,c}; This is giving a key describing the right side of the tile. Those keys are then used in associations to build the topological constraints. The key can be anything so if you want to add new tiles, you can just use the key you want to describe the sides of your tiles. The generic function rightSide must be extended with new cases when new tiles are added. Then, we need to express how good the tiles are approximating the original picture. For this, an error function is created. It is a sum of terms: ![eq4][10] It means that if the tile i is selected for pixel (x,y) then the approximation error is `Subscript[f, k]` The function averageColor must be extended with new tiles. It returns the color content of a tile : a RGBColor. The code is using a color distance to compute the errors. That's why the input picture is always converted to RGB and the alpha channel removed. So, finally we have translated our problem into a set of integer constraints and with a linear cost function to optimize. It is a mixed integer programming problem which can be solved with LinearOptimization. The tiles must be displayed. It is done by the function tileDraw and the tile is drawn in a square from (0,0) to (1,1) corners. The code is rasterizing those graphics into 50x50 pixel images. I have had lots of problems with those pictures due to rounding errors ... probably due to the very old GPU on my very old computer. So I tuned the vector code assuming the final tile image is 50x50 pixels. Now the pictures are well aligned, there is no more one row or one column of wrong pixels on the boundary of the tiles. But this may cause a problem on your configuration. So, if the tile pictures are not rendering correctly on your side, you'll need to tune my vector graphic code again. If the picture is too big, solving the full mixed integer programming problem may take too long. But we can solve a sub-optimal problem. We divide the picture into sub-pictures and solve the problem on each sub-picture then we recombine the solutions. For it to work : we must add new constraints to express compatibility between the pictures. For instance, the left side of a picture at (row,col) must be compatible with the right side of the picture at (row,col-1). So, the problem must be solved in a given order so that the constraints can be propagated from one sub-picture to the other. For some tiles, the sub-optimal solution can be very good from an artistic point of view (the dark tiles below are working well). For other tiles (the smith tiles in the notebook) either the sub-optimal problem cannot always be solved (because the constraints coming from the previous pictures can't be satisfied) or the sub-optimal problem will look bad from time to time. So this idea of using sub-picture is really dependent on the kind of tiles used. You need to experiment. But it is art after all. Example of use -------------- First, we get an example picture: srcImage = ImageCrop[ExampleData[{"TestImage", "Girl3"}], {190, 270}] The picture is resized, converted to RGB and any alpha channel removed. imgToAnalyze = ImageResize[ ImageAdjust[ RemoveAlphaChannel[ColorConvert[srcImage, "RGB"], Black]], {50, Automatic}] For the dark tiles (knots), we decide to only use gray levels. First color is the background of the tiles. Other colors are for the circles and vertical and horizontal bands. tileData = mkDarkTiles[RGBColor[ 0.5, 0.5, 0.5], {RGBColor[0., 0., 0.], RGBColor[1., 1., 1.]}]; It gives a total of 16 tiles. The more tiles, the more difficult it is to solve the problem. 16 is ok on my old computer. tileData["allTilesImg"] // Length The problem is solved on 15x15 sub pictures. solution = partitionSolve[tileData, imgToAnalyze, 15]; The final picture is generated from the tiles and the solution. img = createPict[tileData, solution]; And you'll get: ![Girl3Gray][2] Have fun ! I hope the vectorial code will not have to be tuned to generate the tile pictures (rounding errors). The notebook is attached to the post. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Girl3.png&userId=89693 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Girl3Gray.png&userId=89693 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Girl3Color.png&userId=89693 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Tiles.png&userId=89693 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Allowed.png&userId=89693 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Forbidden.png&userId=89693 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=eq1.png&userId=89693 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=eq2.png&userId=89693 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=eq3.png&userId=89693 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=eq4.png&userId=89693 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=LenaGray.png&userId=89693 Christophe Favergeon 2020-12-11T16:08:18Z https://community.wolfram.com/groups/-/m/t/2626487 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/fc6be98d-cddb-4a63-a091-b712c48b7758 Chase Marangu 2022-09-30T04:50:44Z https://community.wolfram.com/groups/-/m/t/566363 [Alan Joyce][1] sent me some neat code of analysis of Republican Debate Sep. 16, 2015. **Please do see his analytics below**. Transcripts of debate can be found online. Alan mined most popular words used by the candidates filtered and re-weighted by different criteria. Properly weighted [WordClouds][2] are a good way to grasp key topics. I just wanted to point to graph & networks take on the data. I thought that some candidates may share some top words they use. So if the candidates are nodes, then a weighted edge between them reflects upon how many top words they share. If you consider 1 top word per candidate then the graph will be completely disconnected as each candidate has own unique single top word. As you increase top words' pool some of them will be common and shared between some candidates and links between nodes will appear. Percolation is the moment when, driven by top-words pool-size, all candidates become connected. In the opposite limit of large pool-size all candidates are connected and we get a complete graph. So below is the percolation moment that happens at 5 top words per candidate. **It is indicative of which candidates speak about top common subjects.** CommunityGraphPlot[HighlightGraph[SetProperty[g, EdgeLabels -> None], Table[Style[e, Opacity[.7], Thickness[.005 PropertyValue[{g, e}, EdgeWeight]]], {e, EdgeList[g]}]], CommunityBoundaryStyle -> Directive[Red, Dashed, Thick], CommunityRegionStyle -> {Directive[Opacity[.1], Red], Directive[Opacity[.1], Yellow], Directive[Opacity[.1], Blue]}] ![enter image description here][3] The edge thickness is reflective of number of common words. Grouping shows clustering of candidates around common words. And vertex size come from DegreeCentrality. DegreeCentrality will give high centralities to vertices that have high vertex degrees. So candidates with top words similar to more other candidates will have larger vertices. Clustered CommunityGraphPlot was derived from the top words: topWords = Sort[Normal[highFrequencyForCloud[#]], #1[[2]] > #2[[2]] &][[;; 5]][[All, 1]] & /@ candidates; TableForm[topWords, TableHeadings -> {candidates, None}] ![enter image description here][4] ( refining text filters would narrow top words more precisely ) and WeightedAdjacencyGraph: mocw = Outer[Length[Intersection[#1, #2]] &, topWords, topWords, 1] (1 - IdentityMatrix[10]) /. 0 -> Infinity; mocw // MatrixForm g = WeightedAdjacencyGraph[candidates, mocw, VertexLabels -> "Name", EdgeLabels -> "EdgeWeight",EdgeLabelStyle -> 15, VertexLabelStyle -> 14, VertexSize -> "DegreeCentrality", GraphStyle -> "ThickEdge", GraphLayout -> "CircularEmbedding", VertexStyle -> Directive[Opacity[.8], Orange]] ![enter image description here][5] ![enter image description here][6] For top words extraction and better refinement see Alan's analysis right below. The notebook is attached to his post. [1]: http://community.wolfram.com/web/alanj [2]: http://reference.wolfram.com/language/ref/WordCloud.html [3]: /c/portal/getImageAttachment?filename=qe345yrehgfsge354y6thrgfdasd.png&userId=11733 [4]: /c/portal/getImageAttachment?filename=2015-09-18_03-16-06.png&userId=11733 [5]: /c/portal/getImageAttachment?filename=ScreenShot2015-09-18at3.17.04AM.png&userId=11733 [6]: /c/portal/getImageAttachment?filename=sdaft546ejytrgearwrqtwrhsbgfdasv.png&userId=11733 Vitaliy Kaurov 2015-09-17T22:19:15Z https://community.wolfram.com/groups/-/m/t/2542490 ![enter image description here][1] The excellent [community contribution][2] by [@Greg Hurst][at0] and a Wikipedia [animation][3], Inspired me to look further into this "rolling shutter effect on rotating objects". When we capture a video of a rotating disk with a rolling shutter, we have two independent movements: the colored disk rotating at *rps revolutions per second* and the shutter line sweeping one frame at *fps frames per second*. The ratio rps/fps is the driver of the rolling shutter effect (or the disk rps alone if we normalize the shutter fps to 1 frame per second). In order to best demonstrate this effect, ratios of rps/fps are taken to be in the range 1.5-2.5 This is a colored disk of m pixels wide, rotated over an angle theta. colors = {RGBColor[1, 0, 1], RGBColor[0.988, 0.73, 0.0195], RGBColor[ 0.266, 0.516, 0.9576], RGBColor[0.207, 0.652, 0.324], RGBColor[ 0, 0, 1], RGBColor[1, 0, 0]}; colorDisk[theta_, m_, cols_] := ImageResize[ Image[Graphics[ MapThread[{#3, Disk[{0, 0}, 1, {#1, #2} + theta]} &, {Pi Range[0, 5, 1]/3, Pi Range[1, 6]/3, colors}]]], m] A video of the rotating disk consists of a series of frames. Each frame is captured during one passage of the shutter line. The function *angularPosition* links the angular progress of the disk to the frame number (frm) and the row number at the position of the shutter line: angularPosition[frm_, row_, rps_, m_] := -2 Pi (-1 + (-1 + frm) m + row) rps/m Th function *diskFrameImage* computes the result of the shutter line swiping a colored disk (of size m, rotating at rps revolutions per second) at frame number frm and up to row number toRow: diskFrameImage[frm_, toRow_, rps_, m_, cols_] := ImageAssemble[ Transpose@{ParallelTable[ ImageTake[ colorDisk[angularPosition[frm, r, rps, m], m, colors], {r}], {r, toRow}]}] This is the first frame of a video of a disk rotating at a speed ratio rps/fps of 1 : With[{m = 200, frm = 1, rps = 1}, diskFrameImage[frm, m, rps, m, colors]] ![enter image description here][4] This shows the influence of the disk rps/fps ratio on the appearance of the first frame captured: With[{m = 200, frm = 1}, Grid[{{"rps=0.512", "rps=1.512", "rps=2.512"}, diskFrameImage[frm, m, #, m, colors] & /@ {.512, 1.512, 2.512}}]] ![enter image description here][5] Below is a GIF showing the capture of the first frame of a disk rotating at rps/fps 1. The code is used to generate all of the following GIFs. With[{m = 200, frm = 1, rps = 1.}, Animate[ Grid[{{ ImageCompose[ colorDisk[angularPosition[frm, row, rps, m], m, colors], Graphics[Line[{{-m, 0}, {m, 0}}]], Scaled[{.5, (m - row)/m}]], ImageCompose[diskFrameImage[frm, row, rps, m, colors], Graphics[Line[{{-m, 0}, {m, 0}}]], Scaled[{.5, .01}]]}}, Alignment -> Top], {row, 1, m}]] ![enter image description here][6] Below are 4 examples showing the capture of the first frame of a video of a rotating disk with a roller shutter at 1fs. The disk rotates at 0.5 rps (top left), 1.0 rps (top right), 1.5 rps (bottom left) and 2.0 rps (bottom right). As the disk rotates faster relative to the shutter, the captured image becomes more complex. ![enter image description here][7] ![enter image description here][8] The subsequent frames are captured the same way. Below are the first 5 frames of a video of a disk rotating at 1.5123 rps: ![enter image description here][9] There ought to be a lot more images that result from the transformation of a rotation into a capture with a rolling shutter. I hope this contribution can inspire more community members. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=combirotodisk15and2.gif&userId=20103 [2]: https://community.wolfram.com/groups/-/m/t/2489445 [3]: https://upload.wikimedia.org/wikipedia/commons/1/15/Rolling_shutter_effect_animation.gif [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8345locusfulldiskrps1.png&userId=68637 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9528colordiskrpscompare.png&userId=68637 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=newrotodiskfrm1rps05small.gif&userId=68637 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=combirotodisk05and10.gif&userId=68637 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=combirotodisk15and2.gif&userId=68637 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=allframesvideofinal.gif&userId=68637 [at0]: https://community.wolfram.com/web/ghurst Erik Mahieu 2022-06-02T12:22:57Z https://community.wolfram.com/groups/-/m/t/2316573 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=image%281%29.png&userId=2316532 [2]: https://www.wolframcloud.com/obj/b413a444-3a6d-4675-8984-99255ca6959e Sidharth Jain 2021-07-15T18:30:57Z https://community.wolfram.com/groups/-/m/t/2858759 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=HattilingsviaHTPFequivalence.png&userId=20103 [2]: https://www.wolframcloud.com/obj/8834ec94-ab97-4b06-9446-1654c806e062 Brad Klee 2023-03-24T23:19:15Z https://community.wolfram.com/groups/-/m/t/2516662 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/afc17dcc-20ac-4990-a933-02fed606f0af Anton Antonov 2022-04-22T17:14:10Z https://community.wolfram.com/groups/-/m/t/1732586 ![Feature Space Plot for speech data][1] ### *Figure Above: Feature Space Plot for speech data* ---------- ## Abstract In this project, I aim to design a system which is capable of detecting mood in human speech. Specifically, the system can be trained on a single user's voice given samples of emotional speech labeled as being angry, happy, or sad. The system is then able to classify future audio clips of the user's speech as having one of these three moods. I collected voice samples of myself and trained a Classifier Function based on this data. I experimented with many different available methods for the Classifier Function and for audio preprocessing to obtain the most accurate Classifier. ## Obtaining Data In this project, I focused on detecting mood for only one user (specifically, myself) since different people may express mood in different ways, leading to confusion for the Classifier. I initially recorded ten speech clips in each mood as training data, and ten different clips in each mood as testing data. I used [Audacity](https://www.audacityteam.org/) to record audio clips in 32-bit floating point resolution, exported as WAV files. If you're looking to replicate this project, you can use your own data, or use mine, available on [my GitHub repository](https://github.com/vedadehhc/MoodDetector). I later recorded additional clips, as discussed below. ## Feature Extraction In order to produce the most accurate Classifier, I extracted features which I thought were most useful to detecting mood. Specifically, I extracted the amplitudes, fundamental frequencies, and formant frequencies of each clip over the length of the clip using [AudioLocalMeasurements](https://reference.wolfram.com/language/ref/AudioLocalMeasurements.html). That is, I took multiple measurements of each of these values, over many partitions of the clip. I partitioned each clip into 75 parts, but feel free to experiment with different values. I also found the word rate, using Wolfram Language's experimental [SpeechRecognize](https://reference.wolfram.com/language/ref/SpeechRecognize.html) function, and the ratio of pausing time to total time of the clip using [AudioIntervals](https://reference.wolfram.com/language/ref/AudioIntervals.html). The final function takes the location of the audio file (could be local or on the web) and the number of partitions, and returns an association with the extracted features. It's important that the function return an association, since this makes things much easier when constructing the Classifier Function. The initial function for feature extraction is included below. extractFeatures[fileLocation_, parts_] := Module[{audio, assoc, pdur, amp, freq, form}, audio = Import[fileLocation]; pdur = AudioMeasurements[audio, "Duration"]/parts; amp = AudioLocalMeasurements[audio, "RMSAmplitude", PartitionGranularity -> pdur] // Normal; freq = AudioLocalMeasurements[audio, "FundamentalFrequency", MissingDataMethod -> {"Interpolation", InterpolationOrder -> 1}, PartitionGranularity -> pdur] // Normal; form = AudioLocalMeasurements[audio, "Formants", PartitionGranularity -> pdur] // Normal; assoc = <| Table["amplitude" <> ToString[i] -> amp[[i]][[2]], {i, Length[amp]}], Table["frequency" <> ToString[i] -> freq[[i]][[2]], {i, Length[freq]}], "wordrate" -> Length[TextWords[Quiet[SpeechRecognize[audio]]]]/ AudioMeasurements[audio, "Duration"], Table[Table["formant" <> ToString[i] <> "-" <> ToString[j] -> form[[i]][[j]], {j, Length[form[[i]]]}], {i, Length[form]}], "pauses" -> Total[Abs /@ Subtract @@@ AudioIntervals[audio, "Quiet"]]/ AudioMeasurements[audio, "Duration"] |>; Map[Normal, assoc, {1}] ] ### Get Training Data Using this function, I was able get the features for all of my training data. Here, I'll import my data from [my GitHub repository](https://github.com/vedadehhc/MoodDetector). angryTrainingFeats = Table[extractFeatures[ "https://github.com/vedadehhc/MoodDetector/raw/master/AudioData/ TrainingData/angry" <> ToString[i] <> ".wav", 75], {i, 10}]; happyTrainingFeats = Table[extractFeatures[ "https://github.com/vedadehhc/MoodDetector/raw/master/AudioData/ TrainingData/happy" <> ToString[i] <> ".wav", 75], {i, 10}]; sadTrainingFeats = Table[extractFeatures[ "https://github.com/vedadehhc/MoodDetector/raw/master/AudioData/ TrainingData/sad" <> ToString[i] <> ".wav", 75], {i, 10}]; ### Get Testing Data I also imported my testing data in the same way, so that it could be passed as an argument to the Classifier Function. I'll get this from GitHub as well. Note that this is the regular test data on GitHub. angryTestingFeats = Table[extractFeatures[ "https://github.com/vedadehhc/MoodDetector/raw/master/AudioData/ TestingData/Regular/a" <> ToString[i] <> ".wav", 75], {i, 10}]; happyTestingFeats = Table[extractFeatures[ "https://github.com/vedadehhc/MoodDetector/raw/master/AudioData/ TestingData/Regular/h" <> ToString[i] <> ".wav", 75], {i, 10}]; sadTestingFeats = Table[extractFeatures[ "https://github.com/vedadehhc/MoodDetector/raw/master/AudioData/ TestingData/Regular/s" <> ToString[i] <> ".wav", 75], {i, 10}]; ## Training a Classifier I constructed a Classifier Function using [Classify](https://reference.wolfram.com/language/ref/Classify.html). classifier = Classify[<|"angry" -> angryTrainingFeats, "happy" -> happyTrainingFeats, "sad" -> sadTrainingFeats|>, Method -> "LogisticRegression"] I ran the classifier on each set of training data. classifier[angryTrainingFeats] classifier[happyTrainingFeats] classifier[sadTrainingFeats] I experimented with all of the built-in options for [Method](https://reference.wolfram.com/language/ref/Method.html) to construct a Classifier Function with the best accuracy. I found that [LogisticRegression](https://reference.wolfram.com/language/ref/method/LogisticRegression.html) gave the best accuracy at 77% accuracy on the test data. However, I wanted to improve the accuracy further. ## Audio Pre-Processing One of the things that improved the Classifier's accuracy substantially was cleaning the audio before extracting features and classifying. Specifically, I trimmed the audio using [AudioTrim](https://reference.wolfram.com/language/ref/AudioTrim.html), and filtered each clip using [HighpassFilter](https://reference.wolfram.com/language/ref/HighpassFilter.html) before extracting features. The audio cleaning function is included below. cleanAudio[fileLocation_] := Module[{audio, trimmed, filtered}, audio = Import[fileLocation]; trimmed = AudioTrim[audio]; filtered = HighpassFilter[trimmed, Quantity[300, "Hertz"]] ] ### New Feature Extraction Function I updated the feature extraction function to include audio cleaning. extractCleanFeatures[fileLocation_, parts_] := Module[{audio, assoc, pdur, amp, freq, form}, audio = cleanAudio[fileLocation]; pdur = AudioMeasurements[audio, "Duration"]/parts; amp = AudioLocalMeasurements[audio, "RMSAmplitude", PartitionGranularity -> pdur] // Normal; freq = AudioLocalMeasurements[audio, "FundamentalFrequency", MissingDataMethod -> {"Interpolation", InterpolationOrder -> 1}, PartitionGranularity -> pdur] // Normal; form = AudioLocalMeasurements[audio, "Formants", PartitionGranularity -> pdur] // Normal; assoc = <| Table[ "amplitude" <> ToString[i] -> amp[[i]][[2]], {i, Length[amp]}], Table[ "frequency" <> ToString[i] -> freq[[i]][[2]], {i, Length[freq]}], "wordrate" -> Length[TextWords[Quiet[SpeechRecognize[audio]]]]/ AudioMeasurements[audio, "Duration"], Table[ Table["formant" <> ToString[i] <> "-" <> ToString[j] -> form[[i]][[j]], {j, Length[form[[i]]]}], {i, Length[form]}], "pauses" -> Total[Abs /@ Subtract @@@ AudioIntervals[audio, "Quiet"]]/ AudioMeasurements[audio, "Duration"] |>; Map[Normal, assoc, {1}] ] ### New Results Using audio cleaning, the accuracy of the classifier improved to 90%, much better than before. The results can be seen in the Confusion Matrix Plot below, generated using [ClassifierMeasurements](https://reference.wolfram.com/language/ref/ClassifierMeasurements.html). ![Confusion Matrix Plot for Regular Data][2] ## Testing with Neutral Statements Now, up until now, the statements used for recordings were all emotional in nature. For example, the clips recorded in an angry mood also had an angry statement being said. In order to control for this, I recorded neutral statements in each mood. That is, I recorded each of ten emotionally neutral statements in each of the three moods. If the Classifier still works on this data, that would show that it is not relying on the content of the speech, but on other audio features, which is the intended method. I imported these data using the clean feature extractor and, once again, I'll download them from my GitHub here. Note that this is the Neutral Statements data. nAngryCleanTestingFeats = Table[extractCleanFeatures[ "https://github.com/vedadehhc/MoodDetector/raw/master/AudioData/ TestingData/NeutralStatements/a" <> ToString[i] <> ".wav", 75], {i, 10}]; nHappyCleanTestingFeats = Table[extractCleanFeatures[ "https://github.com/vedadehhc/MoodDetector/raw/master/AudioData/ TestingData/NeutralStatements/h" <> ToString[i] <> ".wav", 75], {i, 10}]; nSadCleanTestingFeats = Table[extractCleanFeatures[ "https://github.com/vedadehhc/MoodDetector/raw/master/AudioData/ TestingData/NeutralStatements/s" <> ToString[i] <> ".wav", 75], {i, 10}]; ### Results for Neutral Statements I ran the clean Classifier on the new data, and the results were very positive. The classifier achieved an accuracy of 97% on the Neutral Statements data. The results are displayed in the Confusion Matrix Plot below, generated using [ClassifierMeasurements](https://reference.wolfram.com/language/ref/ClassifierMeasurements.html). ![Confusion Matrix Plot for Neutral Statements Data][3] ## Conclusions Overall, the Classifier was able to identify mood at 93% accuracy, even when the same statements were spoken in different moods. The composite Confusion Matrix Plot for all testing data can be seen below. ![Confusion Matrix Plot for all test data][4] ## Future Work In the future, I hope to improve the accuracy of the Classifier by providing additional training data, and to test it further with additional testing data. I also hope to expand the range of moods that the Classifier handles, including moods such as fear, calmness, and excitement. This, of course, would require the aforementioned additional data, and perhaps, more complex structures for the Classifier Function. In the future I would also like to experiment with multiple speakers, and determine whether classifiers for one speaker's moods can be used to determine those of another speaker. ## Acknowledgements I would like to thank my mentor Faizon Zaman for his guidance and assistance on this project. ## GitHub You can find my code for this project on [my GitHub repository](https://github.com/vedadehhc/MoodDetector), with all code available beginning July 12th, 2019. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=featureSpacePlotNoLabel.png&userId=1724789 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=CMP1.png&userId=1724789 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=CMP2.png&userId=1724789 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=CMP3.png&userId=1724789 Dev Chheda 2019-07-12T01:16:42Z https://community.wolfram.com/groups/-/m/t/3067969 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=_2_ezgif.com-optimizecopy.gif&userId=11733 [2]: https://www.wolframcloud.com/obj/34c7205a-40cd-4587-b6a1-f1fadc1ed8ce Vitaliy Kaurov 2023-11-21T01:14:10Z https://community.wolfram.com/groups/-/m/t/1379001 # Punctuation Restoration With Recurrent Neural Networks Mengyi Shan, Harvey Mudd College, mshan@hmc.edu ![flow][1] All codes posted on GitHub: [https://github.com/Shanmy/Summer2018Starter/tree/master/Project][2]. Raw results in the attached notebook. ---------- ## Introduction In natural language processing problems such as automatic speech recognition (ASR), the generated text is normally unpunctuated, which is hard for further recognition or analysis. Thus punctuation restoration is a small but crucial problem that deserves our attention. This project aims to build an automatic "punctuation adding" tool for plain English text with no punctuation. Since the input text could be considered as a sequence in which context is important for every single word's properties, recurrent characteristics of neural networks are considered to be a good method. Traditional approaches to this problem include usage of various recurrent neural networks (RNN), especially long short-term memory layers (LSTM). This project examines several models built from different layers and introduces bidirectional operators which can significantly improve the result compared with old methods. ## Methods ![Basic steps of the method][3] There're four basic steps in the whole process. First, we get the corpus of articles (with punctuations). Then, we keep the periods and commas in the corpus but change the question marks, exclamation marks, and colons to periods and commas, while removing all other punctuations. With this pure text, we tag each word as one of {NONE, COMMA, PERIOD} by judging if it is followed by a punctuation or not. And this set of tagging rules are sent to a neural network model for training. Finally, we test the result on another piece of articles, which is the test set. ### Data Basically, we have two pieces of data. The first one is the Wikipedia text of 4000 nouns (deleting missing), and the second is 50 novels from Wolfram data repository. (*Get wikipedia text of 4000 nouns*) nounlist = Select[WordList[], WordData[#, "PartsOfSpeech"][[1]] == "Noun" &]; rawData = StringJoin @@ DeleteCases[Flatten[WikipediaData[#] & /@ Take[nounlist, {1, 4000}], 2], _Missing] (*Get text of 50 novels*) books = StringJoin @@ Get /@ ResourceSearch["novels", 50]; ### Pre-processing The first goal of the preprocessing step is to purify the text. That is, since we only consider commas and periods, we should either delete or replace other characters and punctuations. Also, for convenience, all numbers are replaced with 1 first. All other characters are removed from the text. (*Show sets of characters replaced with comma, period, whitespace, one and null respectively*) toComma = Characters[":;"]; toPeriod = Characters["!?"]; toWhiteSpace = {"-", "\n"}; toOne = {"0", "1", "2", "3", "4", "5", "6", "7", "8", "9"}; toNull[x_String] := Complement[Union[Characters[x]], ToUpperCase@Alphabet[], Alphabet[], toOne, toComma, toPeriod, toWhiteSpace, {".", ",", " "}]; Then complete the replacement and modify it to pure form. And we include a validation test to examine its purity. (*Replacement and modification. End with lowercase text with only periods, alphabets and commas.*) toPureText[x_String] := StringReplace[#, ".," .. -> ". "] &@ StringReplace[#, ". " .. -> ". "] &@ StringReplace[#, {" ," -> ",", " ." -> "."}] &@ StringReplace[#, {"1" .. -> "one", " " .. -> " "}] &@ StringReplace[#, {"1. 1" -> "", "1, 1" -> "1"}] &@ StringReplace[#, {" " .. -> " "}] &@ StringReplace[#, {"," -> ", ", "." -> ". "}] &@ ToLowerCase@ StringReplace[{toComma -> ",", toPeriod -> ".", toNull[x] -> "", toWhiteSpace -> " ", toOne -> "1"}][x]; (*validation test*) VerificationTest[Length@StringSplit@x == Length@TextWords@x] Then we define a function fPuncTag that can generate the corresponding tagging given a piece of text with punctuation. (*Define the tagging function, and maps it to original text. Original text is partitioned into pieces of 200 words*) fPuncTag := Switch[StringTake[#, -1], ".", "a", ",", "b", _, "c"] &; fWordTag[x_String] := Map[fPuncTag, Partition[StringSplit[x], 200], {2}]; And we can thus remove the punctuation, and build a set of rules between the unpunctuated text and the generated tagging. fWordText[x_String] := StringReplace[#, {"," -> "", "." -> ""}] & /@ StringRiffle /@ Partition[StringSplit[x], 200]; fWordTrain[x_String] := Normal@AssociationThread[fWordText[x], fWordTag[x]]; totalData = fWordTrain@toPureText@rawText With the total data, we want to divide it into three groups: the training set, the validation set, and the test set. (* First we know that the length is 63252, then we divide it by 15:3:1*) order = RandomSample[Range[63252]]; trainingSet = totalData[[Take[order, 50000]]]; validationSet = totalData[[Take[order, {50001, 60000}]]]; testSet = totalData[[Take[order, {60001, -1}]]]; ### Train During neural network training, I used 8 different combinations of layers, out of which 4 are worth considering. They are listed as followed. LSTM layer, gate recurrent layer, and basic recurrent layer are three types of recurrent layers, each representing a net that takes a sequence of vectors and outputs a sequence of the same length. LSTM is commonly used in natural language processing problems, so we start with it as a penetrating point. (*Pure LSTM*) net1 = NetChain[{ embeddingLayer, LongShortTermMemoryLayer[100], LongShortTermMemoryLayer[60], LongShortTermMemoryLayer[30], LongShortTermMemoryLayer[10], NetMapOperator[LinearLayer[3]], SoftmaxLayer["Input" -> {"Varying", 3}]}, "Output" -> NetDecoder[{"Class", {"a", "b", "c"}}] ]; (*Gate Recurrent*) net2 = NetChain[{ embeddingLayer, LongShortTermMemoryLayer[100], GatedRecurrentLayer[60], LongShortTermMemoryLayer[30], GatedRecurrentLayer[10], NetMapOperator[LinearLayer[3]], SoftmaxLayer["Input" -> {"Varying", 3}]}, "Output" -> NetDecoder[{"Class", {"a", "b", "c"}}] ]; (Basic Recurrent) net3 = NetChain[{ embeddingLayer, LongShortTermMemoryLayer[100], BasicRecurrentLayer[60], LongShortTermMemoryLayer[30], BasicRecurrentLayer[10], NetMapOperator[LinearLayer[3]], SoftmaxLayer["Input" -> {"Varying", 3}]}, "Output" -> NetDecoder[{"Class", {"a", "b", "c"}}] ]; (*Bidirectional*) net4 = NetChain[{ embeddingLayer, LongShortTermMemoryLayer[100], NetBidirectionalOperator[{LongShortTermMemoryLayer[40], GatedRecurrentLayer[40]}], NetBidirectionalOperator[{LongShortTermMemoryLayer[20], GatedRecurrentLayer[20]}], LongShortTermMemoryLayer[10], NetMapOperator[LinearLayer[3]], SoftmaxLayer["Input" -> {"Varying", 3}]}, "Output" -> NetDecoder[{"Class", {"a", "b", "c"}}] ]; The embedding layer is used to change words into vectors that represent their semantic characteristics. (*The embedding layer here*) embeddingLayer = NetModel["GloVe 100-Dimensional Word Vectors Trained on Wikipedia and Gigaword 5 Data"] With all those neural network models set up, we can train each neural network. To save time, I first trained all models with a small data set of only 3 million words to compare their behaviors. (*train the neural network while saving the training object*) NetTrain[net, trainingSet, All, ValidationSet -> validationSet] ### Test Since this classification problem is a problem of a skewed dataset, that is, most of the words should have the tag "None", it doesn't make sense to use "accuracy" to measure the models' behavior. Even if it simply do nothing and always return "None", it will have a high accuracy that is the percentage of "None" in the whole tagging set. Instead, to evaluate the behavior of the models, we introduce the concept of precision, recall, and f1-score. (*Precision and recall*) precision = truePrediction/allTrue recall = truePrediction/allPrediction F1 = HarmonicMean[{precision, recall}] ![PR][4] For a given test set, first, we want to remove its punctuations and run the trained model on it. (*romve punctuation and run the model*) noPuncTest = Keys /@ testSet result = net["TrainedNet"] /@ noPuncTest; Then we changed the tags to 1,2 and 0. And we calculate the elementwise product of realTag and resultTag. If an element is 4, it means that both the realTag and resultTag is 2, which counts as a successful prediction of a comma. An element of 2 represents a successful prediction of a period. ![Tag][5] (*Change the tags to numerical values and count 1s and 4s*) realTag = Replace[Flatten[Values /@ Take[testSet, 3252]], {"a" -> 1, "b" -> 2, "c" -> 0}, {1}]; resultTag = Replace[Flatten[result], {"a" -> 1, "b" -> 2, "c" -> 0}, {1}]; totalTag = realTag*resultTag; Now we can use totalTag, resultTag, and realTag to calculate precision, recall, and f1-score. (*Precision*) PrecPeriod = N@Count[totalTag, 1]/Count[resultTag, 1] PrecComma = N@Count[totalTag, 4]/Count[resultTag, 2] (*Recall*) RecPeriod = N@Count[totalTag, 1]/Count[realTag, 1] RecComma = N@Count[totalTag, 4]/Count[realTag, 2] (*F1*) F1Period = (2*RecPeriod*PrecPeriod)/(RecPeriod + PrecPeriod) F1Comma = (2*RecComma*PrecComma)/(RecComma + PrecComma) ## Result Ten neural networks are trained based on a small dataset with different layers. Only using Long Short-Term Memory layers gives an f1 score of 13% and 11% for periods and commas. Introducing dropout parameters, pooling layers, elementwise layers, basic recurrent layers and gate recurrent layers all produce an f1 score between 10% and 30%, showing no significant improvement. Introduction of the bidirectional operator (combining two recurrent layers) improves the scores to 53% and 47%, and to 72% and 60% respectively when training on a larger dataset of 10M words. Here are the results for the three different neural networks trained with a 3M small dataset, and bidirectional neural network (which has the best performance in the small dataset) trained with a larger dataset of 10M words. The first figure is of the period and the second is of the comma. ![Period][6] ![Comma][7] We can easily observe the advantage of the bidirectional operator in terms of both periods and commas, precision and recall. Instead of the sequence to sequence learning, "tagging" is a significantly more efficient and accurate way to restore punctuation in plain text. Since every words' tags ("None", "Comma", "Period") is influenced by its context, it makes sense that recurrent neural networks and bidirectional operators show great potential in this research. Generally, the recall score is significantly lower than the precision score, suggesting that the model generates too many punctuations than it should. This could be due to the dataset of Wikipedia which is not clean enough. In the Wikipedia text, sometimes there're equations, translations, or other strange characters that we simply delete. This changed the ratio of punctuations to words and produces some segments of text that is "full of" punctuations since all words are not recognized and simply deleted. One example of those "not clean segment" is shown below. ![wiki][8] Also, the overall performance on commas is slightly worse than on periods. This also makes sense from a linguistics point of view. There seems to be a concrete linguistics set of rules for the period, but the usage of comma greatly depends on personal writing style. For example, you could say either *"I like apples but I don't like bananas."*, or *"I like apples, but I don't like bananas."* In this way, it's really hard to build a model for comma prediction with such high accuracy. But fortunately, sometimes adding commas or not doesn't really influence the overall meaning of the sentence. So it's okay to be tolerant to a slightly worse performance on commas. ## Future Works 70% f1-score is still not enough for the application. Planned future work focuses on improving accuracy to a level suitable for usage in industry. The most urgent and important future work is using a larger data size. We can observe great improvement when changing from 3M to 10M dataset, but it's still far less than enough. ![plot][9] If we take a closer look at the evolution plots during training, we can see that the error rate and loss of training set are continuously decreasing, while the error rate and loss of the validation set soon reaches a stable state and doesn't change too much. The gap between those two curves suggests the possibility of overfitting, and it should greatly help if we introduce better and more data. Also, punctuation restoration should not be limited to periods and comma. A more rigorous study of the question mark, exclamation mark, colon, and quotation mark is expected. However, we should note that the choice of most punctuations is not restricted to one possibility. In cases like distinguishing a period with an exclamation mark, we cannot expect a high f1-score. But it's still an interesting topic, may be useful for topics like sentimental analysis. ## Acknowledgement I would like to thank the summer school for providing the environment and background skills for me to finish this project. Especially, I want to thank my mentor for helping me with neural network problems and debugging. ## Data and Reference - [Wolfram Data Repository][10] - [Wikipedia][11] - Tilk O, et al. "Lstm for Punctuation Restoration in Speech Transcripts." Proceedings of the Annual Conference of the International Speech Communication Association, Interspeech, 2015-January, 2015, pp. 683\687. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-10at7.10.22PM.png&userId=1362824 [2]: https://github.com/Shanmy/Summer2018Starter/tree/master/Project [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-11at10.22.30AM.png&userId=1362824 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=PR1.png&userId=1362824 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-11at11.45.44AM.png&userId=1362824 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-10at8.38.40PM.png&userId=1362824 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-10at8.38.49PM.png&userId=1362824 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-11at12.13.54PM.png&userId=1362824 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-07-10at8.59.14PM.png&userId=1362824 [10]: https://datarepository.wolframcloud.com/category/Text-Literature/ [11]: https://www.wikipedia.org Mengyi Shan 2018-07-11T17:20:45Z https://community.wolfram.com/groups/-/m/t/1962739 *MODERATOR NOTE: coronavirus resources & updates:* https://wolfr.am/coronavirus ---------- [updated notebooks in comments - please go to latest] Hello Community, so I am working on enumerating the possible data visualizations of the results that will be coming from a monte carlo simulation of the effects of COVID-19 after various reopening scenarios. This post is strictly seeking contributions to visualizing the toy dataset defined in the attached notebook (the actual simulation is being done by someone else and is not ready yet). If you want to contribute to a system to help educate decision makers about various ways to think about this challenge in the face of great uncertainty in data, simulation, and underlying models, then please download the attached notebook, create a function that visualizes some aspect of the data like the first few examples I have added in the notebook, then post your results here. Given a clean data spec there are so many ways to visualize the data and each way allows someone to answer different questions. Let's help everyone wrap there head around this! Here is a simple graphical model of the data that will come out of the simulation... ![enter image description here][1] Here is the first example of a visualization of one aspect of the data... ![enter image description here][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=covid.png&userId=26311 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1000-100-10_population.png&userId=26311 Kyle Keane 2020-05-03T03:24:46Z https://community.wolfram.com/groups/-/m/t/2847286 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ShakespeareanGPT.png&userId=20103 [2]: https://www.wolframcloud.com/obj/bd95b76b-1086-414d-911a-f9bc349c3527 Jofre Espigule-Pons 2023-03-08T09:33:20Z https://community.wolfram.com/groups/-/m/t/1007290 *NOTE: click on images to see high resolution* ---------- [![enter image description here][1]][2] What is common between a symphony and a novel? They both progress linearly in time. This is why songs match lyrics and music so well. This seems obvious but comprehension of spacial objects is different. You can look at a two-dimensional painting and your sense of art is driven by the simultaneous perception of different spacial regions and their properties: color, contrast, etc. The simultaneous comparison of many different parts is the very mechanism of spacial perception. In contrast an average person cannot read more than one sentence at a time. And listening to the same parts of melody simultaneously can create cacophony or at least shift from the intended by creator sound. Because our consciousness is forced to constantly move though time and not space, we perceive spacial and temporal structures differently. We use memory to improve comprehension of temporal phenomena. But it is till quite hard to remember and compare many different moments simultaneously. Remembering the secondary sense of "relations" or "correlations" between different moments is even harder. What if we could extract important information from a temporal structure and reflect it via a spacial visual representation? As an example let's take US presidents inaugural addresses. They are short pieces of text that at times may seem very similar to each other. So there there are 2 levels of comparison: 1. What are ideas and relations between them in a single speech? 2. What is common and different between different speeches? It is possible to create some very simple tools of text processing that give some immediate insight. In the image above you see a take on Obama 2013 and Trump 2017 inauguration speeches. Top idea-networks reflect the top ideas and relationships between them inside a speech. The top-terms are also clustered to indicate which ideas are in the tighter relationships. And word clouds show common and unique top words for each presidential address. Also notice, that while the common words are "common" they have different weights for each address, which redistributes the meaningful stress between common ideas. The Wolfram Language code for building these objects is below. It works in a very simple way. For word clouds you find unique and common words and then find their statistical weights. For the idea networks it is just a little bit more subtle. First you find "top terms" by deleting stop words and tallying the rest. Than you say that only tally weighting greater than a specific threshold counts as a "main idea" on which you build your network. The edges are drown between top-terms that are direct neighbors in the text. Thresholding of tally could be a bit misleading as selection of this cutoff is subjective and per-candidate specific. This means that a threshold chosen for one candidate may not work as well for the other because they may generate different statistical distribution of top-terms in the speeches. For Obama and Trump in the image above I used slightly different thresholds to get nicer visualizations. As a counterexample, below are net-ideas of inaugural addresses for the rest of 56 US presidents thresholded at the same **"Obama-level"**. As you can see sometimes the nets are overloaded and sometimes they are too simple. Which in itself tells something about different structures of texts and prompt us for careful treatment of the threshold. The final code and more details are given below. [![enter image description here][3]][3] A unique feature of Wolfram Language a multitudes of built-in curated data. We can access all inauguration speeches as allOBJ = SortBy[ResourceData["Presidential Inaugural Addresses"], "Date"]; This is a sample of the dataset: Column[allOBJ /@ {1, -1}] ![enter image description here][4] Extract all texts and names and dates: allTEXT = Normal[allOBJ[All, "Text"]]; allNAME = Normal[allOBJ[All, DateString[#Date, "Year"] <> " " <> CommonName[#Name] &]]; # Idea-network Idea-nets are built ideaNET[text_String,order_]:= Module[ {wordsTOP, edges,resctal, words=TextWords[DeleteStopwords[ToLowerCase[text]]]}, resctal=Transpose[MapAt[N[Rescale[#]]&,Transpose[Tally[words]],2]]; wordsTOP=Select[resctal,Last[#]>=order &]; edges=UndirectedEdge@@@DeleteDuplicates[Sort/@DeleteCases[ Partition[Cases[words,Alternatives@@wordsTOP[[All,1]]],2,1],{x_String,x_String}]]; CommunityGraphPlot[ Graph[edges, VertexSize->Thread[wordsTOP[[All,1]]->.1+.9wordsTOP[[All,2]]], VertexLabels->Automatic,VertexLabelStyle->Directive[20,White,Opacity[.8]], GraphStyle->"Prototype",Background->Black], CommunityBoundaryStyle->Directive[GrayLevel[.4],Dashed], CommunityRegionStyle->GrayLevel[.2], ImageSize->800{1,1}, PlotRangePadding->{{.1,.3},{0.1,0.1}}] ] ## Example: JFK inaugural address: ideaNET[allTEXT[[-15]], .17] [![enter image description here][5]][5] # Unique and common top-terms The code that makes very top graphics is: plusCLOUD[allTEXT[[-2]], allTEXT[[-1]], "o b a m a '13", "t ru m p '17"] With idea-nets defined as above and `plusCLOUD` as below: plusCLOUD[text1_String,text2_String,label1_String,label2_String]:= Module[ {same, words1=TextWords[DeleteStopwords[ToLowerCase[text1]]], words2=TextWords[DeleteStopwords[ToLowerCase[text2]]]}, same=Intersection[words1,words2]; Grid[ {{"",Column[{ Style[label1,80,Blue,FontFamily->"Phosphate"], Style["inaugural address",45,Gray,FontFamily->"Copperplate"] },Alignment->Center], Column[{ Style[label2,80,Red,FontFamily->"Phosphate"], Style["inaugural address",45,Gray,FontFamily->"Copperplate"] },Alignment->Center]}, {Framed[Column[Style[#,35,FontFamily->"DIN Condensed"]&/@Characters["idea network"], Alignment->Center],FrameStyle->White,FrameMargins->10], ideaNET[text1,.21],ideaNET[text2,.18]}, {Framed[Column[Style[#,35,FontFamily->"DIN Condensed"]&/@Characters["unique words"], Alignment->Center],FrameStyle->White,FrameMargins->10], WordCloud[DeleteCases[words1,Alternatives@@same],ImageSize->800{1,1}, ColorFunction->(ColorData["DeepSeaColors"][(.2+#)/1.2]&),Background->Black], WordCloud[DeleteCases[words2,Alternatives@@same],ImageSize->800{1,1}, ColorFunction->(ColorData["ValentineTones"][(.2+#)/1.2]&),Background->Black]}, {Framed[Column[Style[#,35,FontFamily->"DIN Condensed"]&/@Characters["common words"],Alignment->Center],FrameStyle->White,FrameMargins->10], WordCloud[Cases[words1,Alternatives@@same],ImageSize->800{1,1}, ColorFunction->(ColorData["AvocadoColors"][(.2+#)/1.2]&),Background->Black], WordCloud[Cases[words2,Alternatives@@same],ImageSize->800{1,1}, ColorFunction->(ColorData["AvocadoColors"][(.2+#)/1.2]&),Background->Black] }}, Spacings->{0, 0}] ] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trump.png&userId=11733 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trump.png&userId=11733 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=qwe434tgwrefv.png&userId=11733 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-02-03at8.09.19AM.png&userId=11733 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=JFKiadss.png&userId=11733 Vitaliy Kaurov 2017-02-03T14:29:00Z