Community RSS Feed
http://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Graphics and Visualization sorted by activeWhy isn't this FinishDynamic[] working? (or, controlling animations)
http://community.wolfram.com/groups/-/m/t/1103601
Here is a simple example of visualizing a 2d random walk. It is constructed to illustrate my question about FinishDynamic[]
I am also attempting set up controls for an interactive animation. I'd like a dynamic to update and use "stop" and "go" buttons.
Here are two functions that are used in the animation of a simple random walk:
Add a random step to a list of random steps:
updateRandomWalk[list_] :=
Append[list, Last[list] + RandomReal[{-0.5, 0.5}, {2}]]
Visualize the sequence of steps:
displayWalker[list_] := {Line[list], Disk[Last[list]]}
For example:
walkers = ConstantArray[{{0, 0}}, 100];
Do[walkers = updateRandomWalk /@ walkers;, {2000}];
Graphics[displayWalker /@ walkers, PlotRange -> 50 {{-1, 1}, {-1, 1}}]
Attempt to create an animation with a stop and go button. Notice that the FinishDynamic is being ignored--and that the animation stops even if the stop button is not activated.
DynamicModule[{walkers = ConstantArray[{{0, 0}}, 50], animate = False},
Column[
{
Row[{
Button["Go",
animate = True;
While[animate, walkers = updateRandomWalk /@ walkers;
FinishDynamic[];]
],
Button["Stop",
animate = False,
Method -> "Preemptive"
]
}
],
Dynamic[
Graphics[displayWalker /@ walkers,
PlotRange -> 50 {{-1, 1}, {-1, 1}}]
]
}
]
]
Thanks. Mathematica 11.1 on MacOs 10.12.4 (Sierra).W. Craig Carter2017-05-23T12:05:22ZDiffusion localised on the map of France
http://community.wolfram.com/groups/-/m/t/853228
I have this program to simulate diffusion on the map of France
ClearAll["Global`*"]
Needs["NDSolve`FEM`"]
carto = DiscretizeGraphics[CountryData["France", {"Polygon", "Mercator"}]]
![enter image description here][1]
bmesh = ToBoundaryMesh[carto, "MaxBoundaryCellMeasure" -> 25, AccuracyGoal -> 1];
mesh = ToElementMesh[bmesh, MaxCellMeasure -> 5, "MaxBoundaryCellMeasure" -> 25];
mesh["Wireframe"]
![enter image description here][2]
op = -Laplacian[u[x, y], {x, y}] - 20;
usol = NDSolveValue[{op == 1, DirichletCondition[u[x, y] == 0, True]},u, {x, y} \[Element] mesh];
Plot3D[usol[x, y], {x, y} \[Element] mesh, PlotTheme -> "Detailed",
ColorFunction -> "Rainbow", PlotPoints -> 50]
![enter image description here][3]
Show[ContourPlot[usol[x, y], {x, y} \[Element] mesh, ColorFunction -> "Temperature"], bmesh["Wireframe"]]
![enter image description here][4]
I obtained an image of the diffusion.
**But I want that the diffusion process is centered upon Paris. Do you have a solution ?**
Thanks! ~ André Dauphiné
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sdf43rf3q4dfatggfd.svg&userId=11733
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=SADFYIUTR645YRTHFGD.svg&userId=11733
[3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=dfg435utyjhfgdDAfsa.png&userId=11733
[4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sadf4wq5435430fd.png&userId=11733André Dauphiné2016-05-09T07:49:49ZGraphImage2List for multi-colored graph-image-data
http://community.wolfram.com/groups/-/m/t/1102290
In my previous post [GraphImage2List][1], I created the tool that changes graph-image-data to numeric-data in order to do a Machine Learning using graph-image-data. However, it can't deal with multi-colored graph-image-data. So I create a new tool by **ImageGraphics** function. ImageGraphics is one of my favorite new functions in Mathematica v11.1.
**Goal**
-----------------------------------------
The left is the original graph(image data) like CPU Utilization of five virtual machines.
The right is the graph(ListPlot) of yellow-green line picked up by the new tool.
![enter image description here][2]
The tool comes in three steps.
**Step 1**
-----------------------------------------
In the first step, My MakeMasking function masks unnecessary areas around the original image data like plot label, frame and ticks. It outputs "maskedimage".
MakeMasking[img_] := Module[{},
size = {sizex, sizey} = ImageDimensions[img];
backimg = Image[Table[1, {sizey}, {sizex}]];
Manipulate[
Grid[{{"input image", "masked image"},
{Show[img, ImageSize -> size],
Show[
maskedimg =
ImageCompose[backimg,
ImageTrim[
img, {{left, bottom}, {right, top}}], {left + right,
bottom + top}/2], ImageSize -> size]}}],
Row[{Control[{left, 0, sizex, 1}],
Control[{{right, sizex}, 0, sizex, 1}]}, " "],
Row[{Control[{bottom, 0, sizey, 1}],
Control[{{top, sizey}, 0, sizey, 1}]}, " "]
]
]
The left is the original. The right is masked image.
![enter image description here][3]
**Step 2**
-----------------------------------------
In this step, My SelectColors function selects the areas of two near colors in ImageGraphics output of "maskedimage".
ImageGraphics function returns the content of image. The colors are below.
maskedimggraphics = ImageGraphics[maskedimg, PlotRangePadding -> None];
maskedimggraphics[[1, 2, #, 1]] & /@ Range[Length[maskedimggraphics[[1, 2]]]]
![enter image description here][4]
My SelectColors function uses the content and outputs the selected area as "selectpts".
SelectColors[img_, maskedimggraphics_] := Module[{},
{sizex, sizey} = size = ImageDimensions[img] // N;
frame = {{0., 0.}, {0., sizey}, {sizex, sizey}, {sizex, 0.}};
l = Length[maskedimggraphics[[1, 1]]];
colors =
maskedimggraphics[[1, 2, #, 1]] & /@
Range[Length[maskedimggraphics[[1, 2]]]];
Manipulate[
Grid[{{"input image", "selected image"},
{Show[img, ImageSize -> ImageDimensions[img]],
Graphics[
GraphicsComplex[Join[maskedimggraphics[[1, 1]], frame],
Join[{LABColor[
0.9988949153893414, -3.6790844387894895`*^-6,
0.00042430735605277474`],
FilledCurve[{{Line[{l + 1, l + 2, l + 3, l + 4}]}}]},
selectpts =
FirstCase[maskedimggraphics[[1, 2]], {#, ___},
Nothing] & /@ {color1, color2}]],
ImageSize -> size]}}], {{color1, colors[[2]]}, colors,
ControlType -> RadioButton,
Method -> "Queued"}, {{color2, colors[[2]]}, colors,
ControlType -> RadioButton, Method -> "Queued"},
SynchronousUpdating -> False]
]
The left is the original. The right is selected image.
![enter image description here][5]
**Step 3**
-----------------------------------------
You can make list in the next process by using my GetList2 function.
1. Add/del points with alt+click(WINDOWS)/cmd+click(MAC) if necessary
2. Set x and y values(Min, Max, Accuracy) of red points
3. Click Calculate button
GetList2[img_, imggraphics_, selectpts_] := Module[{},
ClearAll[list]; list = {};
Manipulate[
Grid[{{"Selected Points", "Sample List"},
{Show[img, Graphics[{Point[u]}],
ImageSize -> ImageDimensions[img]],
Dynamic[If[(ValueQ[list] == False) || (list == {}),
"1． add/del points if necessary(alt+click/cmd+click）\n
2. set x and y values of red points\n
3. click Calculate button",
Sort[RandomSample[list, UpTo[10]]] // TableForm]]}},
Alignment -> Top],
Row[{Control[{xMin, {0}, InputField, ImageSize -> 100}],
Control[{xMax, {100}, InputField, ImageSize -> 100}],
Control[{{xAccuracy, 1}, InputField, ImageSize -> 50}]}, " "],
Row[{Control[{yMin, {0}, InputField, ImageSize -> 100}],
Control[{yMax, {100}, InputField, ImageSize -> 100}],
Control[{{yAccuracy, 1}, InputField, ImageSize -> 50}]}, " "],
Row[{Button["Calculate",
list = locator2coordinate2[u, xMin, xMax, xAccuracy, yMin, yMax,
yAccuracy];, ImageSize -> 120, Method -> "Queued"]}, " "],
{{u, Sort[GetPointsfromImageGraphics[imggraphics, selectpts]]},
Locator, LocatorAutoCreate -> True,
Appearance -> Style["\[FilledCircle]", Red, 3]},
ControlPlacement -> {Bottom, Bottom, Bottom},
SynchronousUpdating -> False]
]
locator2coordinate2[points_, xMin_, xMax_, xAccuracy_, yMin_, yMax_,
yAccuracy_] :=
Module[{solvex, solvey, pointsx, pointsy, points2, coordinatesL,
coordinatesH, nearx, nearxpos, tmp},
solvex =
Solve[{a*#[[1]] + b == xMin, a*#[[2]] + b == xMax}, {a, b}] &@
MinMax[points[[All, 1]]];
pointsx = Flatten[({a, b} /. solvex).{#, 1} & /@ points[[All, 1]]];
solvey =
Solve[{c*#[[1]] + d == yMin, c*#[[2]] + d == yMax}, {c, d}] &@
MinMax[points[[All, 2]]];
pointsy = Flatten[({c, d} /. solvey).{#, 1} & /@ points[[All, 2]]];
points2 = Sort[Thread[{pointsx, pointsy}]];
coordinatesL = (points2 //. {s___, {u_, v_}, {u_, w_},
t___} -> {s, {u, v}, t});
coordinatesH = (points2 //. {s___, {u_, v_}, {u_, w_},
t___} -> {s, {u, w}, t});
(* High value *)
nearx = (Nearest[coordinatesH[[All, 1]], #, 1] & /@
Range[xMin, xMax, xAccuracy] // Flatten);
nearxpos =
Position[coordinatesH[[All, 1]], #, 1, 1] & /@ nearx // Flatten;
nearyH = Round[#, yAccuracy] & /@ coordinatesH[[All, 2]][[nearxpos]];
(* Low value *)
nearx = (Nearest[coordinatesL[[All, 1]], #, 1] & /@
Range[xMin, xMax, xAccuracy] // Flatten);
nearxpos =
Position[coordinatesL[[All, 1]], #, 1, 1] & /@ nearx // Flatten;
nearyL = Round[#, yAccuracy] & /@ coordinatesL[[All, 2]][[nearxpos]];
(* Middle value *)
nearyM = (nearyH + nearyL)/2;
(* Combination value *)
tmp = ((#[[1]] + #[[3]])/2) & /@ Partition[nearyM, 3, 1];
nearyC = Table[Which[
nearyM[[i + 1]] > tmp[[i]], nearyH[[i + 1]],
nearyM[[i + 1]] < tmp[[i]], nearyL[[i + 1]],
True, Round[nearyM[[i + 1]], yAccuracy]], {i, Length[tmp]}];
PrependTo[nearyC, Round[nearyM[[1]], yAccuracy]];
AppendTo[nearyC, Round[nearyM[[-1]], yAccuracy]];
Thread[{Range[xMin, xMax, xAccuracy], nearyC}]
]
![enter image description here][6]
Set x and y values(Min, Max, Accuracy) of red points and click.
![enter image description here][7]
Then it outputs "list".
list
![enter image description here][8]
ListPlot of the list is below.
ListPlot[Style[list, RGBColor[204/255, 204/255, 0]], Joined -> True]
![enter image description here][9]
**Differences**
-----------------------------------------
When GetList2 converts area selected in Step 2. to coordinates, there are some points of the same x coordinate. So my locator2coordinate2 function outputs 4 lists of y coordinate, high, low, middle and combination as nearyH, nearyL, nearyM and nearyC. As I show below, nearyC seems to be better than others.
I create this image data below.
data = {{6, 5, 33, 36, 9, 11, 23, 29, 34, 26, 3, 6, 26, 35, 21, 6, 26, 33, 20, 16, 30, 6, 1, 6},
{41, 34, 43, 60, 33, 38, 54, 43, 29, 59, 45, 34, 42, 55, 42, 26, 59, 20, 20, 41, 41, 47, 28, 52},
{58, 55, 61, 56, 40, 47, 50, 72, 72, 66, 69, 69, 78, 75, 70, 66, 56, 76, 66, 43, 47, 79, 56, 49},
{88, 96, 84, 62, 69, 67, 61, 60, 94, 76, 75, 70, 69, 86, 68, 61, 72, 91, 89, 71, 69, 83, 88, 75},
{17, 9, 23, 19, 23, 47, 45, 30, 82, 88, 58, 24, 59, 61, 17, 82, 95, 83, 40, 81, 68, 5, 40, 7}};
graph =
DateListPlot[data, {2017, 5, 20, 0}, Frame -> True,
FrameLabel -> {"Time", "CPU Utilization %"}, PlotStyle -> 96];
img = Rasterize[graph]
Mean and Variance of the difference between the true list(data) and calculated 4 list(nearyH, nearyL, nearyM and nearyC) are below and nearyC is the best of all.
Grid[
Join[{{"", "nearyH", "nearyM", "nearyL", "nearyc"}},
Join[{{"Mean", "Variance"}},
{Mean[#], Variance[#]} & /@ {nearyH - #, nearyM - #, nearyL - #,
nearyC - #} &@data[[5]] // N] // Transpose] // Transpose,
Frame -> All]
![enter image description here][10]
ListPlot[{Legended[Style[data[[5]], RGBColor[204/255, 204/255, 0]],
"data[[5]]"], Legended[Style[nearyC, Red], "nearyC"]},
Joined -> {True, False}, PlotRange -> {0, 100}]
![enter image description here][11]
[1]: http://community.wolfram.com/groups/-/m/t/1079933?p_p_auth=tIi9evRT
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=screenshot.0.jpg&userId=1013863
[3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=9670screenshot.2.jpg&userId=1013863
[4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1885screenshot.8.jpg&userId=1013863
[5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=10670screenshot.3.jpg&userId=1013863
[6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1651screenshot.4.jpg&userId=1013863
[7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=9510screenshot.5.jpg&userId=1013863
[8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=6445screenshot.12.jpg&userId=1013863
[9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2322screenshot.7.jpg&userId=1013863
[10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1844screenshot.9.jpg&userId=1013863
[11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=6267screenshot.6.jpg&userId=1013863Kotaro Okazaki2017-05-22T20:20:01ZApply four color theorem to the map of Florida?
http://community.wolfram.com/groups/-/m/t/1078687
I'm attempting to apply the Four Color Theorem to a map of Florida and I'm following an example available among the standard collection of examples located at: ref/GeoGraphics; "Neat Examples" (provided by my Mathematica software). Unfortunately; the following:
EntityProperty["AdministrativeDivision", "BorderingCounties"]
doesn't work when I evaluate it using my Mathematica software. I found an alternative way to get around this difficulty and I can apply the four color theorem to subareas of the map of Florida but, the same code that I use for the subareas will not work for the whole state. I have built the attached Mathematica notebook explaining my problem in detail. Thank you for your help!Gilmar Rodriguez-Pierluissi2017-05-01T14:14:45Z[GIF] Inevitability ((7, 3)-torus knot)
http://community.wolfram.com/groups/-/m/t/1100242
![(7, 3)-torus knot][1]
**Inevitability**
Same basic code as [_To Infinity_][2], but this time with a $(7,3)$ torus knot and simpler lighting. Also, viewed from above rather than from the front.
Stereo3D[{x1_, y1_, x2_, y2_}] := {x1/(1 - y2), y1/(1 - y2), x2/(1 - y2)};
pqtorus[t_, p_, q_] := 1/Sqrt[2] {E^(p I t), E^(q I t)};
With[{viewpoint = {0, 0, 10},
cols = RGBColor /@ {"#EDF2F6", "#494953"}},
Manipulate[
Graphics3D[{Sphere[#, .1] & /@
Table[Stereo3D[Flatten[ReIm /@ pqtorus[t + θ, 7, -3]]], {t, 0, 2 π, 2 π/200}]},
PlotRange -> 3, ViewPoint -> viewpoint,
ViewVertical -> {0, 1, 0}, Boxed -> False,
Background -> cols[[-1]], ImageSize -> 540,
Lighting -> {{"Point", cols[[1]], {0, 0, 1/2}}, {"Ambient", cols[[-1]], viewpoint}}],
{θ, 0, π/100}]
]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=knots14.gif&userId=610054
[2]: http://community.wolfram.com/groups/-/m/t/1099081Clayton Shonkwiler2017-05-22T02:37:15ZDisplay dynamic data?
http://community.wolfram.com/groups/-/m/t/1102243
Hi
So i tried to display data dynamically but it dosent work.
When i put **Dynamic[data, UpdateInterval -> 2]** where my data is **FinancialData["NASDAQ:AAPL"]**,when i press shift i can see the current value of the data but it dosent update it with the dynamic function. What am i doing wrong ?
Same when i put
Dynamic[DateListPlot[data, Joined -> True],
SynchronousUpdating -> False]
,if i press shift i receive a message saying
DateListPlot::ldata: 1.1231` is not a valid dataset or list of datasets.
I hope soemone can help me.Thanksalex grover2017-05-22T16:22:18Zrayshade 4mm version 11.0 released: Raytracing using Mathematica Front End
http://community.wolfram.com/groups/-/m/t/1098411
See your Graphics3D beautifully rendered and Shown or Manipulated to right in your front end, without all the hardware and software (ie without Export to 3DStudio et al).
https://sourceforge.net/projects/rayshade-math/
(rendering it's slower but "better" Mathematica's GL/CL, rendering can produce astounding looks for some graphics, but rendering is not good for mapping and many other sciences. it's good for leisure certainly!)
For use with Mathematica 4.0 - 11.0. Makes file.ray or .pov that will look much like image in notebook except rendered in 3D using raytracing. Results Show in front-end. A few more Mathematica primitives supported but more-so all features do more of what Mathematica does, and with greater control. Also works with many Graphics (ie 2D pie charts) as well. However 11.0 is too big to comment on: many will work many not.
Raytracing can make images of some Graphics3D more realistic compared to even GL/CL/Cuda (game and geo/mapping accelerated 3D).
(3DStudio Art renderer or others are ostensibly upwardly better renderers than rayshade and povray, only the two free renderers are supported at this time)
POVRay is supported about as well.
For an amimation and a very few pics see:
http://community.wolfram.com/groups/-/m/t/1096001
![enter image description here][1]
https://sourceforge.net/projects/rayshade-math/
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-03-28at12.39.31PM.png&userId=1095727John Hendrickson2017-05-19T01:45:47ZGet 3D-printable Batman logo given cross section?
http://community.wolfram.com/groups/-/m/t/1099649
Hi, I am new to Mathematica. For a school project we have to do a model of a 3D shape with a known base and cross sections (i.e. squares, circles, etc...), find the volume of that shape via integration, and present the 3D model. Does anyone know how to get a diagram of this model on Mathematica, and how to use that model to get a 3D printable version of the shape? This is the plot for base I am working with:
![enter image description here][1]
Plot[{
With[{
w=3*Sqrt[1-(x/7)^2],
l=(6/7)*Sqrt[10]+(3+x)/2-(3/7)*Sqrt[10]*Sqrt[4-(x+1)^2],
h=(1/2)*(3*(Abs[x-1/2]+Abs[x+1/2]+6)-11*(Abs[x-3/4]+Abs[x+3/4])),
r=(6/7)*Sqrt[10]+(3-x)/2-(3/7)*Sqrt[10]*Sqrt[4-(x-1)^2]},
w+(l-w)*UnitStep[x+3]+(h-l)*UnitStep[x+1]+(r-h)*UnitStep[x-1]+(w-r)*UnitStep[x-3]],
(1/2)*(3*Sqrt[1-(x/7)^2]+Sqrt[1-(Abs[Abs[x]-2]-1)^2]+Abs[x/2]-((3*Sqrt[33]-7)/112)*x^2-3)*
((x+4)/Abs[x+4]-(x-4)/Abs[x-4])-3*Sqrt[1-(x/7)^2]},
{x,-7,7}, AspectRatio->Automatic]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=10552Untitled-3.png&userId=11733Cameron Walker2017-05-21T00:05:28ZMister Rogers' Sweater Colors
http://community.wolfram.com/groups/-/m/t/1098967
If you (like me) are both a data geek *and* a Fred-Rogers-raised child of the 70's, you probably caught Owen Phillips's nice piece of cardigan-centric data science yesterday — [Every Color Of Cardigan Mister Rogers Wore From 1979–2001][1]. He posted his [R code][2] for scraping and visualizing the data on GitHub, but I wanted to see if I could improve slightly on that dataset and post something that other Wolfram Language users could tinker with.
With a little bit of experimentation, I found that I could generate a nice little dataset with two lines of code. First, a function that takes an episode number, finds the original air date (on Tim Lybarger's excellent [neighborhoodarchive.com][3]), and turns it into a DateObject:
epDate[ep_] :=
Cases[Import[
"http://www.neighborhoodarchive.com/mrn/episodes/" <> ep <>
"/index.html", "FullData"], {"Air Date", date_} :>
DateObject[date], Infinity][[1]]
And second, some code that scrapes episode numbers and approximate sweater colors out of a neighborhoodarchive.com blog post (archived by the Internet Archive), then uses the previous function to get an air date for each episode (and sweater):
sweats = Dataset[<|"EpisodeNumber" -> First@#,
"Date" -> epDate@First@#,
"SweaterColor" -> Last@#|> & /@ (Cases[
Import["https://web.archive.org/web/20110525014454/http:\
//neighborhoodarchive.blogspot.com/2011/05/sweater-colors.html",
"XMLObject"],
XMLElement[
"td", {"colspan" -> "1", "rowspan" -> "1",
"bgcolor" -> col__}, {XMLElement[
"div", {"align" -> "center",
"class" -> "style8"}, {ep___}]}] :>
Rule[ep, RGBColor@col], Infinity] //.
XMLElement[_, _, {episode_}] :> episode)];
To save others the trouble of scraping and regenerating all this data, I went an extra step and submitted a new ResourceObject to the Wolfram Data Repository ([Mister Rogers' Sweater Colors][4]), so you can immediately grab it and start producing interesting visualizations and analyses...
Grid[With[{data =
Row[Sort[#]] & /@
Normal[GroupBy[
ResourceData[
"Mister Rogers' Sweater Colors"], #Date["Year"] &][[All, All,
"SweaterColor"]]]}, Transpose[{Keys[data], Values[data]}]],
Alignment -> {Left, Center}]
![enter image description here][5]
[1]: https://theawl.com/every-color-of-cardigan-mister-rogers-wore-from-1979-2001-83c1faba2677
[2]: https://github.com/Henryjean/Rogers-Cardigans
[3]: http://www.neighborhoodarchive.com/
[4]: https://datarepository.wolframcloud.com/resources/Mister-Rogers-Sweater-Colors
[5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=mrs.png&userId=21095Alan Joyce2017-05-20T00:52:35ZGeoRegionValuePlot[] only works with certain CountryData[] properties?
http://community.wolfram.com/groups/-/m/t/1099203
I found the first command in the help page for `CountryData[]`.
GeoRegionValuePlot[EntityClass["Country", "Asia"] -> "LiteracyRate"]
Then I looked at the properties and tried a few more. Confusingly some work and some do not. Is there any rhyme or reason to this?
GeoRegionValuePlot[EntityClass["Country", "Asia"] -> "PovertyFraction"]
GeoRegionValuePlot[EntityClass["Country", "Asia"] -> "FemalePopulation"]
GeoRegionValuePlot[ EntityClass["Country", "Asia"] -> "ElectricityConsumption"]
GeoRegionValuePlot[EntityClass["Country", "Asia"] -> "LaborForce"]
Of course, extracting the data, and building the list input to this command also works, thusly:
GeoRegionValuePlot[
Flatten[{# -> CountryData[#, "PovertyFraction"]} & /@ EntityList[EntityClass["Country", "Asia"]]]]
Thanks in advance.Aeyoss Antelope2017-05-20T01:29:12Z[GIF] To Infinity ((2,1) torus knot)
http://community.wolfram.com/groups/-/m/t/1099081
![(2,1) torus knot][1]
**To Infinity**
This one is very simple: just a $(2,1)$-torus knot (which of course is topologically an unknot) viewed from straight on (rather than above, which is the more common viewpoint for torus knots). I quite like the blending of colors on the spheres, which was achieved by placing a total of 16 point source lights on a grid in the scene.
The downside of using so many lights in `Lighting` is that it really slows things down. Just based on quick-and-dirty experimentation, it seems like everything slows to a crawl when you get above about 10 distinct light sources.
That being said, here's code using only 8 point lights (plus one ambient light source) that looks almost the same as the animation and is fast enough to `Manipulate` reasonably. If you really want to recreate the animation, use `d=0.82` rather than `d=0.8` and use ` {j, 0, n, δ}` rather than ` {j, 2, n, δ}`.
Stereo3D[{x1_, y1_, x2_, y2_}] := {x1/(1 - y2), y1/(1 - y2), x2/(1 - y2)};
pqtorus[t_, θ_, p_, q_] := 1/Sqrt[2] {E^(p I (t + θ/p)), E^(q I t)};
With[{viewpoint = {2, 0, 0}, d = .8, n = 3, δ = 1, m = 30,
cols = RGBColor /@ {"#08D9D6", "#FF2E63", "#252A34"}},
Manipulate[
Graphics3D[
{Sphere[#, .1] & /@
Table[Stereo3D[Flatten[ReIm /@ pqtorus[t + θ, 0, 2, 1]]], {t, 0., 2 π, 2 π/m}]},
PlotRange -> 3, ViewPoint -> viewpoint, ViewVertical -> {1, 0, 0},
ViewAngle -> π/9, ViewCenter -> {.38, .5, .5}, Boxed -> False,
Background -> cols[[-1]], ImageSize -> 540,
Lighting ->
Append[Flatten[
Table[{"Point", Darker[Blend[Reverse@cols[[;; 2]], i/n], d], {3/2 (j - n/2), 3/2 (i - n/2), 0}},
{i, 0, n, δ}, {j, 2, n, δ}], 1],
{"Ambient", cols[[-1]], viewpoint}]],
{θ, 0., 2 π/m}]
]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=knots25.gif&userId=610054Clayton Shonkwiler2017-05-19T20:35:14ZThe periodic table - powered by Mathematica
http://community.wolfram.com/groups/-/m/t/1098055
Recently, I've been working on a project called Mandy, an interactive periodic table that displays different element trends depending on what the user says to her. The Raspberry Pi/Mathematica duo has played a very strong role in all aspects of the project design and implementation.
I'm not allowed to provide too many details about the project (not because it's secret, but because I am moving in a month and my wife has ordered that all of my toys and hobbies get packed or I risk them being left behind). Therefore, I [created a teaser trailer](https://www.youtube.com/watch?v=eI-IgJ3n_RU) showcasing the design with a promise to provide more details when I get settled in my new location.
That said, I wanted to highlight a couple of areas where Mathematica played a pivotal role in the the project. My goal was to create a periodic table display (approximately 24x18") that has a RGB LED for each element. The color of the element would then be based on a given periodic trend (atomic radius, weight, ionization energy, etc.). Controlling 118 3-color LEDs turns out to be very easy when the LEDs are Neopixels and the controller is an Arduino. Because I envisioned a wall display, I wanted the user to interact with the piece in some fashion other than a mouse or keyboard. I have started working on a voice recognition system based on pocketsphinx which I call [Simplified Command and Control - SCAC](https://bobthechemist.com/2015/12/prelude-to-simplified-command-and-control/) but since it is a C/Python project, I'll leave that component for another forum. In summary, the final project requires that SCAC (a python script) interact with Mathematica (data manipulation) that then speaks to an Arduino via a serial connection. But Mathematica played a big role prior to the implementation as well:
## Design
- With access to `ElementData`, I was able to very quickly create an image that could be sent to a laser cutter for carving the birch-wood frame and the acrylic element pieces.
o = Table[
Map[ElementData[i, #] &, {"AtomicNumber", "Symbol", "Period",
"Group"}], {i, 118}];
(* Need to massage the f-block elements,giving them fake groups and \
periods.Making their periods 9 and 10 with their groups 3 through 16 \
works nicely *)
o[[57 ;; 70]] = Module[{i = 1, rep = Range[3, 16], tmp},
tmp = Select[o, 57 <= #[[1]] <= 70 &] /. {6 -> 9};
tmp /. {Missing["NotApplicable"] :> rep[[i++]]}];
o[[89 ;; 102]] = Module[{i = 1, rep = Range[3, 16], tmp},
tmp = Select[o, 89 <= #[[1]] <= 102 &] /. {7 -> 10};
tmp /. {Missing["NotApplicable"] :> rep[[i++]]}];
o = o /. {"Uut" -> "Nh", "Uup" -> "Mc", "Uus" -> "Ts", "Uuo" -> "Og"};
piece = Polygon[{{0, 0}, {1, 0}, {1, 1}, {0, 1}, {0, 0}}];
Clear[box]
box[array_] := Module[{x, y, m = 10},
{x, y} = array[[{4, 3}]];
{FaceForm[None], EdgeForm[Thin],
Rectangle[{m x, m (10 - y)}, {m (x + 1), m (11 - y)}]
(*Inset[Style[array[[2]],10,Bold],{m (x+0.5),m(10.7-y)}],
Inset[Style[array[[1]],8],{m(x+0.5),m(10.2-y)}]*)}
]
makePiece[pt_] := GeometricTransformation[
GeometricTransformation[piece, {pt[[1]], 10 - pt[[2]]}*{1.2, 1.2}],
ScalingTransform[{10, 10}]];
ptpuzzle =
Graphics[{EdgeForm[Thin], FaceForm[None],
makePiece /@ o[[All, {4, 3}]]}];
Clear[letters2]
letters2[array_] := Module[{x, y, m = 10},
{x, y} = array[[{4, 3}]];
{FaceForm[None], EdgeForm[Thin],
(*Rectangle[{m x,m(10-y)},{m(x+1),m(11-y)}]*)
Inset[Style[array[[2]], 8, Bold,
FontFamily -> "Cambria Math"], {m (x + 0.45),
m (10.55 - y)}*{1.2, 1.2}],
Inset[Style[array[[1]], 6,
FontFamily -> "Cambria Math"], {m (x + 0.45), m (10.2 - y)}*{1.2,
1.2}]}
]
ptpuzzlelt = letters2 /@ o // Graphics;
Show[ptpuzzlelt, ptpuzzle, ImageSize -> 600]
![enter image description here][1]
There are easier ways to create a periodic table, but the above method allowed me to create SVG images suitable for tweaking in vector graphics software and cut with the laser cutter.
## Data
Naturally, `ElementData` can provide the physical and chemical properties of the elements that I want to display on Mandy. There's nothing inspiring about this code (grabbing the data, rescaling it and converting values to a corresponding color scheme). Mathematica provided a useful platform for sandboxing what the trends would look like:
![enter image description here][2]
## Implementation
Since speech recognition (SCAC) is written in Python, I needed to control a Mathematica Kernel from within Python. I've [played with this idea before](https://github.com/bobthechemist/python-mathlink) which results in a functioning platform that is error-intolerant (READ: not ready for prime time). Communication with the Arduino is done through a "Serial" device instead of the "Arduino" device because I started this project before the latter was working. That said, it was pretty straightforward to create a Mathematica Package that (a) opens serial communication with the Arduino, (b) Reads in the element-LED data (c) sends a command to the Arduino to light the LEDs.
I plan to post more details about the project, including code and design pictures, in due time. See [my website](https://bobthechemist.com/2017/05/mandy-the-periodic-table-teaser/) for updates. RIght now, it sounds like I've used up my daily allocation of blogging time and have to go pack some boxes.
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Capture.JPG&userId=61884
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trends.gif&userId=61884BoB LeSuer2017-05-18T15:11:29ZUse Quiet[Plot[Piecewise[... to suppress the errors?
http://community.wolfram.com/groups/-/m/t/1097698
Consider the following code:
Manipulate[
Quiet[Plot[
Piecewise[{{Subscript[V, 0]*a,
x < (a/2)}, {Subscript[V,
0]*((a/2) + (2*Abs[x - ((3*a)/4)])), (a/2) <= x <=
a}}], {x, -a, a}]], {a, 0, 5}, {Subscript[V, 0], 0, 5}]
When I evaluate this it does'nt suppress the errors, does anyone have a solution to this?Felix Springer2017-05-18T08:47:10ZCreate a parametric plot, with only positive axes - stability diagram?
http://community.wolfram.com/groups/-/m/t/1097261
Hello everyone!
I started using Mathematica today (have only a little bit OF Matlab experience).
I got the following code:
r[x_]= 2x / (x^2+1)^2;
s[x_] = (x^2 (-1+x^2))/(1+x^2)^2;
ParametricPlot[{r[x],-s[x]}, {x,0,10}, PlotStyle -> {Blue},
AxesLabel->{Style[r,Large],Style[s,Large]},LabelStyle->Directive[Bold]]
My task seems to be quite easy, but I fail:
I want to get this plot, but only with positive s-axis - no negative s-values needed.
Can anybody help me, please?
Thank you so much!m s2017-05-17T20:56:17Z