I have a dataset with labels which I would like to plot with points colored according to their label. Is there a simple way how to get current line numer inside plot, so that I can determine which category does the point belong to?
I understood that x,y,z are the coordinates of plotted data, but it doesn't help for the external labels.
This is quite ugly and it works just on sorted dataset with regular distribution.
data = Import["http://ftp.ics.uci.edu/pub/machine-learning-databases/iris/iris.data"];
data = Drop[data, -1]; (*there one extra line at the end*)
inData = data[[All, 1 ;; 4]];
labels = data[[All, 5]];
ListPlot3D[inData,
ColorFunction ->
Function[{x, y, z},
If[y < 0.33, RGBColor[1, 1, 0.],
If[y < 0.66, RGBColor[1, 0, 0.], RGBColor[1, 0, 1]]
]
]
]
Expected result:
Suppose that points is the lists of coordinates and labels a list of the corresponding labels so for example
points = Flatten[Table[{i, j, Sin[i j]},
{i, 0, Pi, Pi/20}, {j, 0, Pi, Pi/10}], 1];
labels = RandomChoice[{"label a", "label b", "label c"}, Length[points]];
Each label corresponds to a colour which I'm writing as a list of rules, e.g.
rules = {"label a" -> RGBColor[1, 1, 0],
"label b" -> RGBColor[1, 0, 0], "label c" -> RGBColor[1, 0, 1]};
Then the points can be plotted in the colour corresponding to their label as follows
ListPointPlot3D[Pick[points, labels, #] & /# Union[labels],
PlotStyle -> Union[labels] /. rules]
Edit
To colour individual points in a ListPlot3D you can use VertexColors, for example
ListPlot3D[points, VertexColors -> labels /. rules, Mesh -> False]
For Example:
(* Build the labeled structure and take a random permutation*)
f[x_, y_] = Sqrt[100 - x x - y y];
l = RandomSample#Flatten[{Table[{{"Lower", {x, y, f[x, y] - 5}},
{"Upper", {x, y, 5 - f[x, y]}}},
{x, -5, 5, .1}, {y, -5, 5, .1}]}, 3];
(*Plot*)
Graphics3D[
Riffle[l[[All, 1]] /. {"Lower" -> Red, "Upper" -> Green},
Point /# l[[All, 2]]], Axes -> True]
Related
How to make a program in Mathematica that is able to recognize this image and return the radius of the circular part of it?
While curve extraction is possible the radius can be obtained quite simply, i.e.
img = Import["https://i.stack.imgur.com/LENuK.jpg"];
{wd, ht} = ImageDimensions[img];
data = ImageData[img];
p1 = LengthWhile[data[[-33]], # == {1., 1., 1.} &];
p2 = LengthWhile[Reverse[data[[-33]]], # == {1., 1., 1.} &];
p120 = wd - p1 - p2 - 1;
p3 = LengthWhile[data[[-245]], # == {1., 1., 1.} &];
p4 = LengthWhile[Reverse[data[[-245]]], # == {1., 1., 1.} &];
pdrop = wd - p3 - p4 - 1;
radius = 120/p120*pdrop/2.
55.814
Further automation could automatically detect the widest point of the drop, which is here found by testing: line 245 (see sample lines in bottom image).
Making sense of the scale could be difficult to automate. We can see the outermost ticks are at -60 & 60, a length of 120 which turns out to be 400 pixels, pdrop.
As the sketch below shows, the circular part of the drop is limited by the widest points, so that length and the scale are all that is needed to find the radius.
Two lines are used to find the image scale and outer bounds of the drop: line 33 and 245, shown below coloured red.
Additional code
In the code below r is calibrated against the scale so that it equals 60.
img = Import["https://i.stack.imgur.com/LENuK.jpg"];
{wd, ht} = ImageDimensions[img];
Manipulate[
Graphics[{Rectangle[{0, 0}, {wd, ht}],
Inset[img, {0, 0}, {0, 0}, {wd, ht}],
Inset[Graphics[{Circle[{x, y}, r]},
ImageSize -> {wd, ht}, PlotRange -> {{0, wd}, {0, ht}}],
{0, 0}, {0, 0}, {wd, ht}],
Inset[
Style["r = " <> ToString[Round[60 r/212.8, 0.1]], 16],
{50, 510}]},
ImageSize -> {wd, ht}, PlotRange -> {{0, wd}, {0, ht}}],
{{x, 228}, 0, 300}, {{y, 247}, 0, 300}, {{r, 196}, 0, 300}]
I've got a simple ListPlot like
list2 = Table[{x, Sqrt[x]}, {x, 0, 100}];
Now I want to color specific points with RED, say every 5th point, I tried
mycolor[x_] /; Mod[x, 5] == 0 = Red;
mycolor[_] = Blue;
Now
ListPlot[#, PlotStyle -> AbsolutePointSize[3], ColorFunction ->
mycolor[#[[All, 1]], ColorFunctionScaling -> False]] &[list2]
doesnt work quite right, all points are still blue.
What is wrong here?
Thanks,
archi
Here is an easy way to get the result you're after :-
list2 = Table[{x, Sqrt[x]}, {x, 0, 100}];
mycolor[x_] := If[Mod[x, 5] == 0, Red, Blue];
mycolors = mycolor /# list2[[All, 1]];
ListPlot[List /# list2,
PlotStyle -> Map[{AbsolutePointSize[3], #} &, mycolors]]
Alternatively, with a colour function, thanks to rm -rf's answer on george's link :-
list2 = Table[{x, Sqrt[x]}, {x, 0, 100}];
mycolor = Function[{x, y}, If[Mod[x, 5] == 0, Red, Blue]];
ListLinePlot[list2,
PlotStyle -> AbsolutePointSize[3], ColorFunction -> mycolor,
ColorFunctionScaling -> False] /. Line -> Point
Further to comment
For different plot markers I have reverted to the easy method. In order to apply different styles and plot markers in ListPlot the differently styled points have to be in separate lists, hence List /# list2. (Only two lists would actually be necessary though.)
Clear[mycolor];
list2 = Table[{x, Sqrt[x]}, {x, 0, 100}];
mycolor[x_] := If[Mod[x, 5] == 0,
{Red, "\[FilledUpTriangle]", 14},
{Blue, "\[FilledSmallCircle]", 6}];
mycolorspec = mycolor /# First /# list2;
ListPlot[List /# list2,
PlotMarkers -> Apply[Style[#2, FontSize -> #3, #1] &,
mycolorspec, {1}]]
I can plot the curve corresponding to an implicit equation:
ContourPlot[x^2 + (2 y)^2 == 1, {x, -1, 1}, {y, -1, 1}]
But I cannot find a way to color the contour line depending on the location of the point. More precisely, I want to color the curve in 2 colors, depending on whether x² + y² < k or not.
I looked into ColorFunction but this is only for coloring the region between the contour lines.
And I was not able to get ContourStyle to accept a location-dependent expression.
you could use RegionFunction to split the plot in two:
Show[{
ContourPlot[x^2 + (2 y)^2 == 1, {x, -1, 1}, {y, -1, 1},
RegionFunction -> Function[{x, y, z}, x^2 + y^2 < .5],
ContourStyle -> Red],
ContourPlot[x^2 + (2 y)^2 == 1, {x, -1, 1}, {y, -1, 1},
RegionFunction -> Function[{x, y, z}, x^2 + y^2 >= .5],
ContourStyle -> Green]
}]
Maybe something like this
pl = ContourPlot[x^2 + (2 y)^2 == 1, {x, -1, 1}, {y, -1, 1}]
points = pl[[1, 1]];
colorf[{x_, y_}] := ColorData["Rainbow"][Rescale[x, {-1, 1}]]
pl /. {Line[a_] :> {Line[a, VertexColors -> colorf /# points[[a]]]}}
which produces
This does not provide a direct solution to your question but I believe it is of interest.
It is possible to color a line progressively from within ContourPlot using what I think is an undocumented format, namely a Function that surrounds the Line object. Internally this is similar to what Heike did, but her solution uses the vertex numbers to then find the matching coordinates allowing styling by spacial position, rather than position along the line.
ContourPlot[
x^2 + (2 y)^2 == 1, {x, -1, 1}, {y, -1, 1},
BaseStyle -> {12, Thickness[0.01]},
ContourStyle ->
(Line[#, VertexColors -> ColorData["DeepSeaColors"] /# Rescale##] & ## # &)
]
For some of the less adept, less information is more. Time was wasted browsing for a way to set the color of contour lines until I chanced onto Roelig's edited answer. I just needed ContourStyle[].
Show[{ContourPlot[
x^2 + 2 x y Tan[2 # ] - y^2 == 1, {x, -3, 3}, {y, -3.2, 3.2},
ContourStyle -> Green] & /# Range[-Pi/4, Pi/4, .1]},
Background -> Black]
I want to plot a series of lines with one half-space filled for each line. By setting opacity to something less than 1, I want to make the overlaps stand out. What I have looks something like this:
Plot[Table[x + a, {a, 0, 5}], {x, -1/2, 1/2},
RegionFunction -> Function[{x, y}, y < 5],
Filling -> 5, FillingStyle -> Directive[Opacity[0.25]]]
This is fine. Now I want to also shade the colors for each half space in a particular way. Instead of the flat shading for each at present, say I want to shade it by the y value. I.e., if the flat shade color is blue, the shade of blue is scaled by y (0 most intense or 5 most intense doesn't matter). So at the first overlap, it automatically becomes 2y, 3y when two half-spaces overlay.
How do I do this?
You could try ParametricPlot. For example
ParametricPlot[
Table[{s, i + s/2 + t}, {i, 0, 2}], {s, 0, 1}, {t, 0, 3},
Mesh -> False, PlotStyle -> Automatic,
ColorFunctionScaling -> False,
PlotRange -> {Automatic, {0, 3}},
ColorFunction -> Function[{x, y, s, t},
Directive[Opacity[0.2], ColorData["NeonColors"][y/3]]],
AspectRatio -> 1]
Result:
I am looking to plot something like the whispering gallery modes -- a 2D cylindrically symmetric plot in polar coordinates. Something like this:
I found the following code snippet in Trott's symbolics guidebook. Tried running it on a very small data set; it ate 4 GB of memory and hosed my kernel:
(* add points to get smooth curves *)
addPoints[lp_][points_, \[Delta]\[CurlyEpsilon]_] :=
Module[{n, l}, Join ## (Function[pair,
If[(* additional points needed? *)
(l = Sqrt[#. #]&[Subtract ## pair]) < \[Delta]\[CurlyEpsilon], pair,
n = Floor[l/\[Delta]\[CurlyEpsilon]] + 1;
Table[# + i/n (#2 - #1), {i, 0, n - 1}]& ## pair]] /#
Partition[If[lp === Polygon,
Append[#, First[#]], #]&[points], 2, 1])]
(* Make the plot circular *)
With[{\[Delta]\[CurlyEpsilon] = 0.1, R = 10},
Show[{gr /. (lp : (Polygon | Line))[l_] :>
lp[{#2 Cos[#1], #2 Sin[#1]} & ###(* add points *)
addPoints[lp][l, \[Delta]\[CurlyEpsilon]]],
Graphics[{Thickness[0.01], GrayLevel[0], Circle[{0, 0}, R]}]},
DisplayFunction -> $DisplayFunction, Frame -> False]]
Here, gr is a rectangular 2D ListContourPlot, generated using something like this (for example):
data = With[{eth = 2, er = 2, wc = 1, m = 4},
Table[Re[
BesselJ[(Sqrt[eth] m)/Sqrt[er], Sqrt[eth] r wc] Exp[
I m phi]], {r, 0, 10, .2}, {phi, 0, 2 Pi, 0.1}]];
gr = ListContourPlot[data, Contours -> 50, ContourLines -> False,
DataRange -> {{0, 2 Pi}, {0, 10}}, DisplayFunction -> Identity,
ContourStyle -> {Thickness[0.002]}, PlotRange -> All,
ColorFunctionScaling -> False]
Is there a straightforward way to do cylindrical plots like this?.. I find it hard to believe that I would have to turn to Matlab for my curvilinear coordinate needs :)
Previous snippets deleted, since this is clearly the best answer I came up with:
With[{eth = 2, er = 2, wc = 1, m = 4},
ContourPlot[
Re[BesselJ[(Sqrt[eth] m)/Sqrt[er], Sqrt[eth] r wc] Exp[I phi m]]/.
{r ->Norm[{x, y}], phi ->ArcTan[x, y]},
{x, -10, 10}, {y, -10, 10},
Contours -> 50, ContourLines -> False,
RegionFunction -> (#1^2 + #2^2 < 100 &),
ColorFunction -> "SunsetColors"
]
]
Edit
Replacing ContourPlot by Plot3D and removing the unsupported options you get:
This is a relatively straightforward problem. The key is that if you can parametrize it, you can plot it. According to the documentation both ListContourPlot and ListDensityPlot accept data in two forms: an array of height values or a list of coordinates plus function value ({{x, y, f} ..}). The second form is easier to deal with, such that even if your data is in the first form, we'll transform it into the second form.
Simply, to transform data of the form {{r, t, f} ..} into data of the form {{x, y, f} ..} you doN[{#[[1]] Cos[ #[[2]] ], #[[1]] Sin[ #[[2]] ], #[[3]]}]& /# data, when applied to data taken from BesselJ[1, r/2] Cos[3 t] you get
What about when you just have an array of data, like this guy? In that case, you have a 2D array where each point in the array has known location, and in order to plot it, you have to turn it into the second form. I'm partial to MapIndexed, but there are other ways of doing it. Let's say your data is stored in an array where the rows correspond to the radial coordinate and the columns are the angular coordinate. Then to transform it, I'd use
R = 0.01; (*radial increment*)
T = 0.05 Pi; (*angular increment*)
xformed = MapIndexed[
With[{r = #2[[1]]*R, t = #2[[1]]*t, f = #1},
{r Cos[t], r Sin[t], f}]&, data, {2}]//Flatten[#,1]&
which gives the same result.
If you have an analytic solution, then you need to transform it to Cartesian coordinates, like above, but you use replacement rules, instead. For instance,
ContourPlot[ Evaluate[
BesselJ[1, r/2]*Cos[3 t ] /. {r -> Sqrt[x^2 + y^2], t -> ArcTan[x, y]}],
{x, -5, 5}, {y, -5, 5}, PlotPoints -> 50,
ColorFunction -> ColorData["DarkRainbow"], Contours -> 25]
gives
Two things to note: 1) Evaluate is needed to ensure that the replacement is performed correctly, and 2) ArcTan[x, y] takes into account the quadrant that the point {x,y} is found in.