Related
So I'm pretty new to Mathematica, and am trying to learn to solve problems in a functional way. The problem I was solving was to list the ways in which I could sum elements from a list (with repetitions), so the sum is leq to some value. The code below solves this just fine.
i = {7.25, 7.75, 15, 19, 22};
m = 22;
getSum[l_List, n_List] := Total[Thread[{l, n}] /. {x_, y_} -> x y];
t = Prepend[Map[Range[0, Floor[m/#]] &, i], List];
Outer ## %;
Flatten[%, ArrayDepth[%] - 2];
Map[{#, getSum[i, #]} &, %];
DeleteCases[%, {_, x_} /; x > m || x == 0];
TableForm[Flatten /# SortBy[%, Last], 0,
TableHeadings -> {None, Append[i, "Total"]}]
However, the code check a lot of unneccesary cases, which could be a problem if m is higher of the list is longer. My question is simply what would be the most Mathematica-esque way of solving this problem, concerning both efficiency and code elegancy.
One simple though not optimal way is :
sol = Reduce[Dot[i, {a, b, c, d, e}] <= m, {a, b, c, d, e}, Integers];
at first try with a smaller i, say i = {7.25, 7.75} to get a feeling about whether you can use this.
You can improve speed by providing upper limits for the coefficients, like in
sol = Reduce[And ## {Dot[i, {a, b, c, d, e}] <= m,
Sequence ## Thread[{a, b, c, d, e} <= Quotient[m, i]]},
{a, b, c, d, e}, Integers]
How about
recurr[numbers_, boundary_] :=
Reap[memoryRecurr[0, {}, numbers, boundary]][[2, 1]];
memoryRecurr[_, _, {}, _] := Null;
memoryRecurr[sum_, numbers_, restNumbers_, diff_] :=
(
Block[
{presentNumber = First[restNumbers], restRest = Rest[restNumbers]}
,
If[
presentNumber <= diff
,
Block[{
newNumbers = Append[numbers, presentNumber],
newSum = sum + presentNumber
},
Sow[{newNumbers, newSum}];
memoryRecurr[
newSum,
newNumbers,
restRest,
diff - presentNumber
];
]
];
memoryRecurr[sum, numbers, restRest, diff]
];
);
So that
recurr[{1, 2, 3, 4, 5}, 7]
->
{{{1}, 1}, {{1, 2}, 3}, {{1, 2, 3}, 6}, {{1, 2, 4}, 7}, {{1, 3},
4}, {{1, 4}, 5}, {{1, 5}, 6}, {{2}, 2}, {{2, 3}, 5}, {{2, 4},
6}, {{2, 5}, 7}, {{3}, 3}, {{3, 4}, 7}, {{4}, 4}, {{5}, 5}}
I am plotting a table of data using ListPlot in Mathematica. I notice that there are a few asymptotes on the graph which I do not want it to be plotted (i.e. the straight lines between the curves). What should I do to remove the straight lines?
A method from Mark McClure's post here: How to annotate multiple datasets in ListPlots
t = Table[Tan[i], {i, -Pi, Pi, .01}];
plot = ListLinePlot[t];
DeleteCases[plot, Line[_?(Length[#] < 4 &)], Infinity]
Perhaps:
t = Table[Tan[i], {i, -Pi, Pi, .01}];
ListPlot[#, Joined -> True] & /# {t, t /. x_ /; Abs#x > 10 -> None}
Edit
More robust:
t = Table[Tan[i], {i, -Pi, Pi, .01}];
ao = AbsoluteOptions[ListPlot[t, Joined -> True],PlotRange]/. {_ -> {_,x_}} ->x;
ListPlot[t /. x_ /; (x < ao[[1]] || x > ao[[2]]) -> None, Joined -> True]
t = Table[Tan[i], {i, -Pi, Pi, .01}];
plot = ListLinePlot[t];
Using Position
Position[plot, Line[___], Infinity]
{{1, 1, 3, 2}, {1, 1, 3, 3}, {1, 1, 3, 4}, {1, 1, 3, 5}, {1, 1, 3, 6}}
Using Part:
plot[[1, 1, 3, 5 ;; 6]] = Sequence[]; Show[plot]
Given pairs of coordinates
data = {{1, 0}, {2, 0}, {3, 1}, {4, 2}, {5, 1},
{6, 2}, {7, 3}, {8, 4}, {9, 3}, {10, 2}}
I'd like to extract peaks and valleys, thus:
{{4, 2}, {5, 1}, {8, 4}}
My current solution is this clumsiness:
Cases[
Partition[data, 3, 1],
{{ta_, a_}, {tb_, b_}, {tc_, c_}} /; Or[a < b > c, a > b < c] :> {tb, b}
]
which you can see starts out by tripling the size of the data set using Partition. I think it's possible to use Cases and PatternSequence to extract this information, but this attempt doesn't work:
Cases[
data,
({___, PatternSequence[{_, a_}, {t_, b_}, {_, c_}], ___}
/; Or[a < b > c, a > b < c]) :> {t, b}
]
That yields {}.
I don't think anything is wrong with the pattern because it works with ReplaceAll:
data /. ({___, PatternSequence[{_, a_}, {t_, b_}, {_, c_}], ___}
/; Or[a < b > c, a > b < c]) :> {t, b}
That gives the correct first peak, {4, 2}. What's going on here?
One of the reasons why your failed attempt doesn't work is that Cases by default looks for matches on level 1 of your expression. Since your looking for matches on level 0 you would need to do something like
Cases[
data,
{___, {_, a_}, {t_, b_}, {_, c_}, ___} /; Or[a < b > c, a > b < c] :> {t, b},
{0}
]
However, this only returns {4,2} as a solution so it's still not what you're looking for.
To find all matches without partitioning you could do something like
ReplaceList[data, ({___, {_, a_}, {t_, b_}, {_, c_}, ___} /;
Or[a < b > c, a > b < c]) :> {t, b}]
which returns
{{4, 2}, {5, 1}, {8, 4}}
Your "clumsy" solution is fairly fast, because it heavily restricts what gets looked at.
Here is an example.
m = 10^4;
n = 10^6;
ll = Transpose[{Range[n], RandomInteger[m, n]}];
In[266]:=
Timing[extrema =
Cases[Partition[ll, 3,
1], {{ta_, a_}, {tb_, b_}, {tc_, c_}} /;
Or[a < b > c, a > b < c] :> {tb, b}];][[1]]
Out[266]= 3.88
In[267]:= Length[extrema]
Out[267]= 666463
This seems to be faster than using replacement rules.
Faster still is to create a sign table of products of differences. Then pick entries not on the ends of the list that correspond to sign products of 1.
In[268]:= Timing[ordinates = ll[[All, 2]];
signs =
Table[Sign[(ordinates[[j + 1]] -
ordinates[[j]])*(ordinates[[j - 1]] - ordinates[[j]])], {j, 2,
Length[ll] - 1}];
extrema2 = Pick[ll[[2 ;; -2]], signs, 1];][[1]]
Out[268]= 0.23
In[269]:= extrema2 === extrema
Out[269]= True
Handling of consecutive equal ordinates is not considered in these methods. Doing that would take more work since one must consider neighborhoods larger than three consecutive elements. (My spell checker wants me to add a 'u' to the middle syllable of "neighborhoods". My spell checker must think we are in Canada.)
Daniel Lichtblau
Another alternative:
Part[#,Flatten[Position[Differences[Sign[Differences[#[[All, 2]]]]], 2|-2] + 1]] &#data
(* ==> {{4, 2}, {5, 1}, {8, 4}} *)
Extract[#, Position[Differences[Sign[Differences[#]]], {_, 2} | {_, -2}] + 1] &#data
(* ==> {{4, 2}, {5, 1}, {8, 4}} *)
This may be not exactly the implementation you ask, but along those lines:
ClearAll[localMaxPositions];
localMaxPositions[lst : {___?NumericQ}] :=
Part[#, All, 2] &#
ReplaceList[
MapIndexed[List, lst],
{___, {x_, _}, y : {t_, _} .., {z_, _}, ___} /; x < t && z < t :> y];
Example:
In[2]:= test = RandomInteger[{1,20},30]
Out[2]= {13,9,5,9,3,20,2,5,18,13,2,20,13,12,4,7,16,14,8,16,19,20,5,18,3,15,8,8,12,9}
In[3]:= localMaxPositions[test]
Out[3]= {{4},{6},{9},{12},{17},{22},{24},{26},{29}}
Once you have positions, you may extract the elements:
In[4]:= Extract[test,%]
Out[4]= {9,20,18,20,16,20,18,15,12}
Note that this will also work for plateau-s where you have more than one same maximal element in a row. To get minima, one needs to trivially change the code. I actually think that ReplaceList is a better choice than Cases here.
To use it with your data:
In[7]:= Extract[data,localMaxPositions[data[[All,2]]]]
Out[7]= {{4,2},{8,4}}
and the same for the minima. If you want to combine, the change in the above rule is also trivial.
Since one of your primary concerns about your "clumsy" method is the data expansion that takes place with Partition, you may care to know about the Developer` function PartitionMap, which does not partition all the data at once. I use Sequence[] to delete the elements that I don't want.
Developer`PartitionMap[
# /. {{{_, a_}, x : {_, b_}, {_, c_}} /; a < b > c || a > b < c :> x,
_ :> Sequence[]} &,
data, 3, 1
]
Say I have three lists: a={1,5,10,15} b={2,4,6,8} and c={1,1,0,1,0}. I want a plot which has a as the x axis, b as the y axis and a red/black dot to mark 1/0. For. e.g. The coordinate (5,4) will have a red dot.
In other words the coordinate (a[i],b[i]) will have a red/black dot depending on whether c[i] is 1 or 0.
I have been trying my hand with ListPlot but can't figure out the options.
I suggest this.
a = {1, 5, 10, 15};
b = {2, 4, 6, 8};
c = {1, 1, 0, 1};
Graphics[
{#, Point#{##2}} & ###
Thread#{c /. {1 -> Red, 0 -> Black}, a, b},
Axes -> True, AxesOrigin -> 0
]
Or shorter but more obfuscated
Graphics[
{Hue[1, 1, #], Point#{##2}} & ### Thread#{c, a, b},
Axes -> True, AxesOrigin -> 0
]
Leonid's idea, perhaps more naive.
f[a_, b_, c_] :=
ListPlot[Pick[Transpose[{a, b}], c, #] & /# {0, 1},
PlotStyle -> {PointSize[Large], {Blue, Red}}]
f[a, b, c]
Edit: Just for fun
f[h_, a_, b_, c_, opt___] :=
h[Pick[Transpose[{a, b}], c, #] & /# {0, 1},
PlotStyle -> {PointSize[Large], {Blue, Red}}, opt]
f[ ListPlot,
Sort#RandomReal[1, 100],
Sin[(2 \[Pi] #)/100] + RandomReal[#/100] & /# Range[100],
RandomInteger[1, 100],
Joined -> True,
InterpolationOrder -> 2,
Filling -> Axis]
Here are your points:
a = {1, 5, 10, 15};
b = {2, 4, 6, 8};
c = {1, 1, 0, 1};
(I deleted the last element from c to make it the same length as a and b). What I'd suggest is to separately make images for points with zeros and ones and then combine them - this seems easiest in this situation:
showPoints[a_, b_, c_] :=
With[{coords = Transpose[{a, b}]},
With[{plotF = ListPlot[Pick[coords, c, #], PlotMarkers -> Automatic, PlotStyle -> #2] &},
Show[MapThread[plotF, {{0, 1}, {Black, Red}}]]]]
Here is the usage:
showPoints[a, b, c]
One possibility:
ListPlot[List /# Transpose[{a, b}],
PlotMarkers -> {1, 1, 0, 1} /. {1 -> { Style[\[FilledCircle], Red], 10},
0 -> { { Style[\[FilledCircle], Black], 10}}},
AxesOrigin -> {0, 0}]
Giving as output:
You could obtain similar results (to those of Leonid) using Graphics:
Graphics[{PointSize[.02], Transpose[{(c/. {1 -> Red, 0 -> Black}),
Point /# Transpose[{a, b}]}]},
Axes -> True, AxesOrigin -> {0, 0}]
What is a good way to draw a smooth curve with specified starting and ending point and restricted to be inside of a piecewise linear tube like below?
(source: yaroslavvb.com)
coords = {1 -> {0, 2}, 2 -> {1/3, 1}, 3 -> {0, 0},
4 -> {(1/3 + 2)/2, 1}, 5 -> {2, 1}, 6 -> {2 + 1/3, 0},
7 -> {2 + 1/3, 2}};
gp = GraphPlot[graph, VertexCoordinateRules -> coords];
pr = {{-1, 3 + 1/3}, {-1 - 1/6, 3 + 1/6}};
scale = 50;
is = -scale*(Subtract ### pr);
lineThickness = 2/3;
graph = {1 -> 2, 3 -> 2, 2 -> 4, 4 -> 5, 5 -> 6, 5 -> 7};
path = {3, 2, 4, 5, 7};
lp = Graphics[{Blue, Opacity[.5],
AbsoluteThickness[lineThickness*scale], Line[path /. coords]}];
Show[lp, gp, PlotRange -> pr, ImageSize -> is]
Perhaps something like this:
coords = {2 -> {1/3, 1}, 1 -> {0, 0}, 3 -> {(1/3 + 2)/2, 1},
4 -> {2, 1}, 5 -> {2 + 1/3, 2}};
pr = {{-1, 3 + 1/3}, {-1 - 1/6, 3 + 1/6}};
scale = 50;
is = -scale*(Subtract ### pr);
lineThickness = 2/3;
graph = {1 -> 2, 2 -> 3, 3 -> 4, 4 -> 5};
gp = GraphPlot[graph, VertexCoordinateRules -> coords];
path = {1, 2, 3, 4, 5};
f = BezierFunction[
SortBy[coords /. Rule[x_, List[a_, b_]] -> List[a, b], First]];
pp = ParametricPlot[f[t], {t, 0, 1}];
lp = Graphics[{Blue, Opacity[.5],
AbsoluteThickness[lineThickness*scale], Line[path /. coords]}];
Show[pp, lp, gp, PlotRange -> pr, ImageSize -> is]
You may gain a better control over the path by adding/removing control points for the Bezier. As I remember "A Bspline is contained in the convex hull of its control points", so you can add control points inside your thick lines (up and down the middlepoints in actual point set, for example) to bound the Bezier more and more.
Edit
The following is a first try to bound the curve. Bad programming, just to get the feeling of what can be done:
coords = {2 -> {1/3, 1}, 1 -> {0, 0}, 3 -> {(1/3 + 2)/2, 1},
4 -> {2, 1}, 5 -> {2 + 1/3, 2}};
pr = {{-1, 3 + 1/3}, {-1 - 1/6, 3 + 1/6}};
scale = 50;
is = -scale*(Subtract ### pr);
lineThickness = 2/3;
graph = {1 -> 2, 2 -> 3, 3 -> 4, 4 -> 5};
gp = GraphPlot[graph, VertexCoordinateRules -> coords];
path = {1, 2, 3, 4, 5};
kk = SortBy[coords /. Rule[x_, List[y_, z_]] -> List[y, z],
First]; f = BezierFunction[kk];
pp = ParametricPlot[f[t], {t, 0, 1}, Axes -> False];
mp = Table[{a = (kk[[i + 1, 1]] - kk[[i, 1]])/2 + kk[[i, 1]],
Interpolation[{kk[[i]], kk[[i + 1]]}, InterpolationOrder -> 1][
a] + lineThickness/2}, {i, 1, Length[kk] - 1}];
mp2 = mp /. {x_, y_} -> {x, y - lineThickness};
kk1 = SortBy[Union[kk, mp, mp2], First]
g = BezierFunction[kk1];
pp2 = ParametricPlot[g[t], {t, 0, 1}, Axes -> False];
lp = Graphics[{Blue, Opacity[.5],
AbsoluteThickness[lineThickness*scale], Line[path /. coords]}];
Show[pp, pp2, lp, gp, PlotRange -> pr, ImageSize -> is]
Edit 2
Or perhaps better yet:
g1 = Graphics[BSplineCurve[kk1]];
Show[lp, g1, PlotRange -> pr, ImageSize -> is]
This one scales quite well when you enlarge the image (the previous ones don't)