Related
Fellows,
I couldn't figure why I am having the warning message from the following code in Mathematica:
data = {{0, 1}, {1, 0.02307044673005989`}, {2,
0.00784879347316981`}, {3, 0.0061305265946403195`}, {4,
0.0008550610216054799`}, {5, 0.00010928133254420425`}, {6,
0.000011431049984759768`}, {7, 1.93788101788827`*^-6}, {8,
1.6278670621771263`*^-6}, {9, 2.6661469926370584`*^-7}, {10,
3.443821224260662`*^-8}, {11, 7.413060538191399`*^-9}, {12,
1.4031525687948224`*^-9}, {13, 5.973790450062338`*^-10}, {14,
1.7434844383850214`*^-10}, {15, 2.6053424128998922`*^-11}, {16,
9.887095524831592`*^-12}, {17, 1.2318024865446659`*^-12}, {18,
2.2125640342387203`*^-13}, {19, 1.3176590670511745`*^-13}, {20,
2.7354393146500743`*^-14}};
fit = NonlinearModelFit[data, a + b Exp[-x/c], {a, b, c}, x,
MaxIterations -> \[Infinity], PrecisionGoal -> MachinePrecision,
WorkingPrecision -> MachinePrecision];
fit["BestFitParameters"] (* THE WARNING APPEARS AFTER CALLING THIS FUNCTION *)
The warning message is:
FittedModel: The precision of the argument function (MachinePrecision) is less than WorkingPrecision (MachinePrecision).
Thanks in advance.
The problem is that many of the data values are small and close to machine precision. You can try linear fitting to the Log of the data values.
data2 = {First[#], Log[Last[#]]} & /# data;
lm = LinearModelFit[data2, x, x]
Show[ListPlot[data2], Plot[lm[x], {x, 0, 20}]]
The first data point {0, 1} does not look right. Are you sure it is correct?
Suppose I have the following three lists:
x = {i, j};
y = {a, b, c};
z = {{1, 2, 3}, {4, 5, 6}};
Where z is the data corresponding to the x and y coordinates, z(x_i,y_j) = z_ij. I need to create an array of the following form:
zz = {{i, a, 1}, {i, b, 2}, {i, c, 3}, {j, a, 4}, {j, b, 5}, {j, c, 6}}
How can I do it efficiently in Mathematica 10.0?
This was my attempt so far:
zz = Table[{x[[ii]], y[[jj]], z[[ii, jj]]}, {ii, 1, Length[x]}, {jj, 1, Length[y]}]~Flatten~1
My ultimate goal is to plot (ListPlot3D[zz]) or interpolate this data (Interpolation[zz]), and x and y may be non-uniformly sampled.
Simplifying Bill's answer
x = {i, j};
y = {a, b, c};
z = {{1, 2, 3}, {4, 5, 6}};
MapThread[Append, {Flatten[Outer[List, x, y], 1], Flatten#z}]
{{i, a, 1}, {i, b, 2}, {i, c, 3}, {j, a, 4}, {j, b, 5}, {j, c, 6}}
Also
Transpose#Append[Transpose#Tuples#{x, y}, Flatten#z]
{{i, a, 1}, {i, b, 2}, {i, c, 3}, {j, a, 4}, {j, b, 5}, {j, c, 6}}
Perhaps
x = {i, j}; y = {a, b, c}; z = {{1, 2, 3}, {4, 5, 6}};
zz=MapThread[Flatten[List[#1,#2]] &, {Flatten[Outer[List,x,y],1], Flatten[z]}]
which returns
{{i, a, 1}, {i, b, 2}, {i, c, 3}, {j, a, 4}, {j, b, 5}, {j, c, 6}}
It seems like there should be a simpler way of doing this.
Join ## (Thread[{x[[#]], y, z[[#]]}, List] & /# {1, 2})
{{i, a, 1}, {i, b, 2}, {i, c, 3}, {j, a, 4}, {j, b, 5}, {j, c, 6}}
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}}
Let’s assume we have a list of elements of the type {x,y,z} for x, y
and z integers. And, if needed x < y < z.
We also assume that the list contains at least 3 such triples.
Can Mathematica easily solve the following problem?
To detect at least one triple of the type {a,b,.}, {b,c,.} and {a,c,.}?
I am more intereseted in an elegant 1-liner than computational efficient solutions.
If I understood the problem, you want to detect triples not necessarily following one another, but generally present somewhere in the list. Here is one way to detect all such triples. First, some test list:
In[71]:= tst = RandomInteger[5,{10,3}]
Out[71]= {{1,1,0},{1,3,5},{3,3,4},{1,2,1},{2,0,3},{2,5,1},{4,2,2},
{4,3,4},{1,4,2},{4,4,3}}
Here is the code:
In[73]:=
Apply[Join,ReplaceList[tst,{___,#1,___,#2,___,#3,___}:>{fst,sec,th}]&###
Permutations[{fst:{a_,b_,_},sec:{b_,c_,_},th:{a_,c_,_}}]]
Out[73]= {{{1,4,2},{4,3,4},{1,3,5}},{{1,4,2},{4,2,2},{1,2,1}}}
This may perhaps satisfy your "one-liner" requirement, but is not very efficient. If you need only triples following one another, then, as an alternative to solution given by #Chris, you can do
ReplaceList[list,
{___, seq : PatternSequence[{a_, b_, _}, {b_, c_, _}, {a_,c_, _}], ___} :> {seq}]
I don't know if I interpreted your question correctly but suppose your list is something like
list = Sort /# RandomInteger[10, {20, 3}]
(*
{{3, 9, 9}, {0, 5, 6}, {3, 4, 8}, {4, 6, 10}, {3, 6, 9}, {1, 4, 8},
{0, 6, 10}, {2, 9, 10}, {3, 5, 9}, {6, 7, 9}, {0, 9, 10}, {1, 7, 10},
{4, 5, 10}, {0, 2, 5}, {0, 6, 7}, {1, 8, 10}, {1, 8, 10}}
*)
then you could do something like
ReplaceList[Sort[list],
{___, p:{a_, b_, _}, ___, q:{a_, c_, _}, ___, r:{b_, c_, _}, ___} :> {p, q, r}]
(* Output:
{{{0, 2, 5}, {0, 9, 10}, {2, 9, 10}}, {{3, 4, 8}, {3, 5, 9},
{4, 5, 10}}, {{3, 4, 8}, {3, 6, 9}, {4, 6, 10}}}
*)
Note that this works since it is given that for any element {x,y,z} in the original list we have x<=y. Therefore, for a triple {{a,b,_}, {a,c,_}, {b,c,_}} \[Subset] list we know that a<=b<=c. This means that the three elements {a,b,_}, {a,c,_}, and {b,c,_} will appear in that order in Sort[list].
To match triples "of the type {a,b,.}, {b,c,.} and {a,c,.}":
list = {{34, 37, 8}, {74, 32, 65}, {48, 77, 18}, {77, 100, 30},
{48, 100, 13}, {100, 94, 55}, {48, 94, 73}, {77, 28, 12},
{90, 91, 51}, {34, 5, 32}};
Cases[Partition[list, 3, 1], {{a_, b_, _}, {b_, c_, _}, {a_, c_, _}}]
(Edited)
(Tuples was not the way to go)
Do you require something like:
list = RandomInteger[10, {50, 3}];
Cases[Permutations[
list, {3}], {{a_, b_, _}, {b_, c_, _}, {a_, c_, _}} /; a < b < c]
giving
{{{0, 1, 2}, {1, 5, 2}, {0, 5, 4}},
{{2, 3, 5},{3, 4, 10}, {2, 4, 5}},
{{6, 8, 10}, {8, 10, 10},{6, 10, 0}},
{{2, 4, 5}, {4, 8, 2}, {2, 8, 5}},
{{2, 4, 5}, {4, 7, 7}, {2, 7, 3}},
{{0, 2, 2}, {2, 7, 3}, {0, 7, 2}},
{{0, 2, 1}, {2, 7, 3}, {0, 7, 2}}}
or perhaps (as other have interpreted the question):
Cases[Permutations[
list, {3}], {{a_, b_, _}, {b_, c_, _}, {a_, c_, _}}];
Suppose I have a series of strips of paper placed along an infinite ruler, with start and end points specified by pairs of numbers. I would like to create a list representing the number of layers of paper at points along the ruler.
For example:
strips =
{{-27, 20},
{ -2, -1},
{-47, -28},
{-41, 32},
{ 22, 31},
{ 2, 37},
{-28, 30},
{ -7, 39}}
Should output:
-47 -41 -27 -7 -2 -1 2 20 22 30 31 32 37 39
1 2 3 4 5 4 5 4 5 4 3 2 1 0
What is the most efficient, clean, or terse way to do this, accommodating Real and Rational strip positions?
Here's one approach:
Clear[hasPaper,nStrips]
hasPaper[y_, z_] := Piecewise[{{1, x <= z && x >= y}}, 0];
nStrips[y_, strip___] := Total#(hasPaper ### strip) /. x -> y
You can get the number of strips at any value.
Table[nStrips[i, strips], {i, Sort#Flatten#strips}]
{1, 2, 3, 3, 3, 4, 5, 5, 5, 5, 5, 5, 4, 3, 2, 1}
Also, plot it
Plot[nStrips[x, strips], {x, Min#Flatten#strips, Max#Flatten#strips}]
Here is one solution:
In[305]:=
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31}, {2,
37}, {-28, 30}, {-7, 39}};
In[313]:= int = Interval /# strips;
In[317]:= Thread[{Union[Flatten[strips]],
Join[Count[int, x_ /; IntervalMemberQ[x, #]] & /# (Mean /#
Partition[Union[Flatten[strips]], 2, 1]), {0}]}]
Out[317]= {{-47, 1}, {-41, 2}, {-28, 2}, {-27, 3}, {-7, 4}, {-2,
5}, {-1, 4}, {2, 5}, {20, 4}, {22, 5}, {30, 4}, {31, 3}, {32,
2}, {37, 1}, {39, 0}}
EDIT Using SplitBy and postprocessing the following code gets the shortest list:
In[329]:=
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31}, {2,
37}, {-28, 30}, {-7, 39}};
In[330]:= int = Interval /# strips;
In[339]:=
SplitBy[Thread[{Union[Flatten[strips]],
Join[Count[int, x_ /; IntervalMemberQ[x, #]] & /# (Mean /#
Partition[Union[Flatten[strips]], 2, 1]), {0}]}],
Last] /. {b : {{_, co_} ..} :> First[b]}
Out[339]= {{-47, 1}, {-41, 2}, {-27, 3}, {-7, 4}, {-2, 5}, {-1,
4}, {2, 5}, {20, 4}, {22, 5}, {30, 4}, {31, 3}, {32, 2}, {37,
1}, {39, 0}}
You may regard this as a silly approach, but I'll offer it anyway:
f[x_]:=Sum[UnitStep[x-strips[[k,1]]]-UnitStep[x-strips[[k,2]]],{k,Length[strips]}]
f/#Union[Flatten[strips]]
f[u_, s_] := Total[Piecewise#{{1, #1 <= x < #2}} & ### s /. x -> u]
Usage
f[#, strips] & /# {-47, -41, -27, -7, -2, -1, 2, 20, 22, 30, 31, 32, 37, 39}
->
{1, 2, 3, 4, 5, 4, 5, 4, 5, 4, 3, 2, 1, 0}
For Open/Closed ends, just use <= or <
Here's my approach, similar to belisarius':
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31}, {2,
37}, {-28, 30}, {-7, 39}};
pw = PiecewiseExpand[Total[Boole[# <= x < #2] & ### strips]]
Grid[Transpose[
SplitBy[SortBy[Table[{x, pw}, {x, Flatten[strips]}], First],
Last][[All, 1]]], Alignment -> "."]
Here's my attempt - it works on integers, rationals and reals, but makes no claim to being terribly efficient. (I made the same mistake as Sasha, my original version did not return the shortest list. So I stole the SplitBy fix!)
layers[strips_?MatrixQ] := Module[{equals, points},
points = Union#Flatten#strips;
equals = Function[x, Evaluate[(#1 <= x < #2) & ### strips]];
points = {points, Total /# Boole /# equals /# points}\[Transpose];
SplitBy[points, Last] /. {b:{{_, co_}..} :> First[b]}]
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31},
{2, 37}, {-28, 30}, {-7, 39}};
In[3]:= layers[strips]
Out[3]= {{-47, 1}, {-41, 2}, {-27, 3}, {-7, 4}, {-2, 5}, {-1, 4}, {2, 5},
{20, 4}, {22, 5}, {30, 4}, {31, 3}, {32, 2}, {37, 1}, {39, 0}}
In[4]:= layers[strips/2]
Out[4]:= {{-(47/2), 1}, {-(41/2), 2}, {-(27/2), 3}, {-(7/2), 4},
{-1, 5}, {-(1/2), 4}, {1, 5}, {10, 4}, {11, 5}, {15, 4}, {31/2, 3},
{16, 2}, {37/2, 1}, {39/2, 0}}
In[5]:= layers[strips/3.]
Out[5]= {{-15.6667, 1}, {-13.6667, 2}, {-9., 3}, {-2.33333, 4}, {-0.666667, 5},
{-0.333333, 4}, {0.666667, 5}, {6.66667, 4}, {7.33333, 5}, {10.,4},
{10.3333, 3}, {10.6667, 2}, {12.3333, 1}, {13., 0}}
Splice together abutting strips, determine key points where number of layers
changes, and calculate how many strips each key point inhabits:
splice[s_, {}] := s
splice[s_, vals_] := Module[{h = First[vals]},
splice[(s /. {{x___, {k_, h}, w___, {h, j_}, z___} :> {x, {k, j},
w, z}, {x___, {k_, h}, w___, {h, j_}, z___} :> {x, {k, j}, w,
z}}), Rest[vals]]]
splicedStrips = splice[strips, Union#Flatten#strips];
keyPoints = Union#Flatten#splicedStrips;
({#, Total#(splicedStrips /. {a_, b_} :> Boole[a <= # < b])} & /# keyPoints)
// Transpose // TableForm
EDIT
After some struggling I was able to remove splice and more directly eliminate points that did not need checking (-28, in the strips data we've been using) :
keyPoints = Complement[pts = Union#Flatten#strips,
Cases[pts, x_ /; MemberQ[strips, {x, _}] && MemberQ[strips, {_, x}]]];
({#, Total#(strips /. {a_, b_} :> Boole[a <= # < b])} & /# keyPoints)
One approach of solving this is converting the strips
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}
,{ 22, 31}, { 2, 37}, {-28, 30}, {-7, 39}}
to a list of Delimiters, marking the beginning or end of a strip and sort them by position
StripToLimiters[{start_, end_}] := Sequence[BeginStrip[start], EndStrip[end]]
limiterlist = SortBy[StripToLimiters /# strips, First]
Now we can map the sorted limiters to increments/decrements
LimiterToDiff[BeginStrip[_]] := 1
LimiterToDiff[EndStrip[_]] := -1
and use Accumulate to get the intermediate totals of intersected strips:
In[6]:= Transpose[{First/##,Accumulate[LimiterToDiff/##]}]&[limiterlist]
Out[6]= {{-47,1},{-41,2},{-28,3},{-28,2},{-27,3},{-7,4},{-2,5},{-1,4}
,{2,5},{20,4},{22,5},{30,4},{31,3},{32,2},{37,1},{39,0}}
Or without the intermediate limiterlist:
In[7]:= StripListToCountList[strips_]:=
Transpose[{First/##,Accumulate[LimiterToDiff/##]}]&[
SortBy[StripToLimiters/#strips,First]
]
StripListToCountList[strips]
Out[8]= {{-47,1},{-41,2},{-28,3},{-28,2},{-27,3},{-7,4},{-2,5},{-1,4}
,{2,5},{20,4},{22,5},{30,4},{31,3},{32,2},{37,1},{39,0}}
The following solution assumes that the layer count function will be called a large number of times. It uses layer precomputation and Nearest in order to greatly reduce the amount of time required to compute the layer count at any given point:
layers[strips:{__}] :=
Module[{pred, changes, count}
, changes = Union # Flatten # strips /. {c_, r___} :> {c-1, c, r}
; Evaluate[pred /# changes] = {changes[[1]]} ~Join~ Drop[changes, -1]
; Do[count[x] = Total[(Boole[#[[1]] <= x < #[[2]]]) & /# strips], {x, changes}]
; With[{n = Nearest[changes]}
, (n[#] /. {m_, ___} :> count[If[m > #, pred[m], m]])&
]
]
The following example uses layers to define a new function f that will compute the layer count for the provided sample strips:
$strips={{-27,20},{-2,-1},{-47,-28},{-41,32},{22,31},{2,37},{-28,30},{-7,39}};
f = layers[$strips];
f can now be used to compute the number of layers at a point:
Union # Flatten # $strips /. s_ :> {s, f /# s} // TableForm
Plot[f[x], {x, -50, 50}, PlotPoints -> 1000]
For 1,000 layers and 10,000 points, the precomputation stage can take quite a bit of time, but individual point computation is relatively quick: