How do I add values of one Table to another in Mathematica? - list

I have created a Table of values known as "value1". The "value1" is nothing but a z co-ordinate values alternatively can be called "zone" . These values depending upon the x co-ordinate and y co-ordinate given as "x" and "y" respectively.
The code is give below
value1 = Table[{(10*(Cos[((x - 75)*2*3.14159)/
200]^2)*(Cos[((y - 75)*2*3.14159)/200]^2)) +
20}, {y, 0, 20, 5}, {x, 0, 20, 5}]
The output of "value1" or "zone" is
{{22.5}, {21.7274}, {21.0305}, {20.4775}, {20.1224}}, {{21.7274}, and so on
I have another table of values known as "value 2". This table also gives me a different z co-ordinate value it can be alternatively called "ztwo" . This values also depends upon the x and y co-ordinates defined by "x" and "y" respectively.
Note the z value is generated defined by the expression given below
(((70 - ((10*(Cos[((x - 75)*2*3.14159)/
200]^2)*(Cos[((y - 75)*2*3.14159)/200]^2)) +
20))*0.3333))
I have used the above expression in the table below to generate the "ztwo" values
value2 = Table[{x,y, (((70 - ((10*(Cos[((x - 75)*2*3.14159)/
200]^2)*(Cos[((y - 75)*2*3.14159)/200]^2)) +
20))*0.3333))}, {y, 0, 20, 5}, {x, 0, 20, 5}]
Output of "value2"
{{{0, 0, 15.8318}, {5, 0, 16.0892}, {10, 0, 16.3215}, {15, 0, 16.5059}, {20, 0, 16.6242}}, {{0, 5, 16.0892}, {5, 5,16.2672}, {10, 5, 16.4277}, {15, 5, 16.555},and so on
As you can see from above the "value2" is in form of
{x1,y1,ztwo1},{x2,y2,ztwo2},{x3,y3,ztwo3}..and so on
I want to create a table of values know as "value3" which is basically the addition z values from "value 1" known to us as "zone" to ONLY the z values of "value2" known to us as "ztwo" to get the table "value3". In table "value3" only the z values change but it SHOULD be expressed as in form below
{0,0,38.3317},{5,0,37.5592},{10,0,36.8623} and so on
Explanation: How do I get the above??
this is the "zone" values:
{{22.5}, {21.7274}, {21.0305}, {20.4775}, {20.1224}}, {{21.7274}, and so on
Below is "ztwo" values but expressed in{x,y,z} format
{{{0, 0, 15.8318}, {5, 0, 16.0892}, {10, 0, 16.3215}, {15, 0, 16.5059},
{20,0,16.6242}}, {{0, 5, 16.0892} and so on
Now I want a table of "value 3" whose z values change since it is the addition of
corresponding z co-ordinate values from table "value1" and table "value2"
{0,0,15.8318+22.5},{5,0,16.0892+21.7274},{10,0,16.3215+36.8623} and so on
Which will lead to the desired, ideal output like this:
{0,0,38.3317},{5,0,37.5592},{10,0,36.8623} and so on
Question
How Do I create the Table "Value3" which give me the desired output by adding the corresponding z values from table "value1" to table "value2"

You have a small typo in your code... there should be a comma between y and (((70 - ... in the definition of value2 in order to get the result that you posted below.
Fixing that, you can do the following to get your result:
value3 = value2;
value3[[All, All, 3]] += value1[[All, All, 1]];
EDIT:
The code above does the addition the way you want it. I think the confusion is because you want each of the three coordinates as a list instead of a matrix. For that, you simply need to Flatten the list at Level 1.
Flatten[value3, 1]
Out[1]= {{0, 0, 38.3317}, {5, 0, 37.8167}, {10, 0, 37.3521}, {15, 0,
36.9833}, {20, 0, 36.7466}, {0, 5, 37.8167}, {5, 5, 37.4608}, {10,
5, 37.1397}, {15, 5, 36.885}, {20, 5, 36.7214}, {0, 10,
37.3521}, {5, 10, 37.1397}, {10, 10, 36.9482}, {15, 10,
36.7962}, {20, 10, 36.6986}, {0, 15, 36.9833}, {5, 15, 36.885}, {10,
15, 36.7962}, {15, 15, 36.7258}, {20, 15, 36.6806}, {0, 20,
36.7466}, {5, 20, 36.7214}, {10, 20, 36.6986}, {15, 20,
36.6806}, {20, 20, 36.669}}

Related

Searching for overlapping integers in different indexes of tuples in a vector

I was wondering how one can search for overlaps in a vector of tuples.
For example, I have the vector<tuple<int, int, int>> combo;, and the elements of the vector is:
{10, 101, 1},
{10, 102, 2},
{12, 102, 3},
{14, 90, 4},
{1, 10, 101},
{2, 10, 102},
{3, 12, 102},
{4, 14, 90},
{101, 1, 10},
{102, 2, 10},
{102, 3, 12},
{90, 4, 14}
Here, you can tell that the bottom 8 tuples are just repeats of the first 4, except the integers are reordered in a different way. I want to find the non-overlapping combinations of the elements, not the permutations of the elements.
If the 1st index of the tuple is called left, second if called middle, and third is called right, then in other words, left, middle, and right can overlap with itself, but not with the other 2 indexes.
Convert the elements to a canonical representation. This allows you use a set data structure or similar to identify duplicates.
I'm assuming here you're trying to find permutations that do not result in one of the elements remaining in place, i.e. for values { a, b, c} the matching permutations would be
{ a, b, c }
{ b, c, a }
{ c, a, b }
Furthermore I'm assuming even if multiple values are the same, they could be considered as listed in any order, i.e. { 1, 1, 2 } would match { 1, 2, 1 } even though the first element remains equal, since we could consider the first element to be the second one in the original.
This allows us use the lexicographically minimal alternative that as the canonical representation.
The following code uses std::array<int, 3> for convenience.
#include <array>
#include <iostream>
#include <map>
#include <vector>
using ValueType = std::array<int, 3>;
constexpr ValueType ToCanonical(ValueType const& original)
{
ValueType p1{ original[1], original[2], original[0] };
ValueType p2 { original[2], original[0], original[1] };
return (std::min)({ original, p1, p2 });
}
int main(void) {
std::vector<ValueType> const values
{
{10, 101, 1},
{10, 102, 2},
{12, 102, 3},
{14, 90, 4},
{1, 10, 101},
{2, 10, 102},
{3, 12, 102},
{4, 14, 90},
{101, 1, 10},
{102, 2, 10},
{102, 3, 12},
//{90, 4, 14},
//{10, 101, 1},
//{101, 10, 1},
//{10, 1, 101},
//{1, 101, 10},
//{1, 1, 2},
//{1, 2, 1},
//{2, 1, 1},
};
std::map<ValueType, size_t> indices;
for (size_t i = 0; i != values.size(); ++i)
{
auto insertResult = indices.try_emplace(ToCanonical(values[i]), i);
if (!insertResult.second)
{
std::cout << "The element at index " << i << " is a duplicate of the element at index " << insertResult.first->second << '\n';
}
}
return 0;
}

xtensor: Select rows with specific column values

I am playing around with xtensor and I just wanted to perform a simple operation to select rows with specific column values. Imagine I've the following array.
[
[0, 1, 1, 3, 4 ]
[0, 2, 1, 5, 6 ]
[0, 3, 1, 3, 2 ]
[0, 4, 1, 5, 7 ]
]
Now I want to select the rows where col2 and col4 has value 3. Which in this case is row 3.
[0, 3, 1, 3, 2 ]
I want to achieve similar to what this answer has achieved.
How can I achieve this in xtensor?
The way to go is to slice with the columns you need, and then look where the condition is true for all columns.
For the latter an overload for xt::all(...) is seemingly not implemented (yet!), but we can use xt::sum(..., axis) to achieve the same:
#include <xtensor/xtensor.hpp>
#include <xtensor/xview.hpp>
#include <xtensor/xio.hpp>
int main()
{
xt::xtensor<int,2> a =
{{0, 1, 1, 3, 4},
{0, 2, 1, 5, 6},
{0, 3, 1, 3, 2},
{0, 4, 1, 5, 7}};
auto test = xt::equal(xt::view(a, xt::all(), xt::keep(1, 3)), 3);
auto n = xt::sum(test, 1);
auto idx = xt::flatten_indices(xt::argwhere(xt::equal(n, 2)));
auto b = xt::view(a, xt::keep(idx), xt::all());
std::cout << b << std::endl;
return 0;
}

Manipulating Tables (or lists) in Mathematcia

For scientific purposes (code research) I am using Mathematica to enumerate all periodic sequences of some linear recurrences. As an example the command
Table[{Mod[i * 2^n + j * 4^n + k * 6^n, 7] },{i, 0, 5}, {j, 0, 5}, {k, 0, 5}, {n, 0, 5}]
allows to enumerate all 216 distinct periodic sequences of linear recurrent sequences in a finite field of order 7 (or mod 7) with characteristic polynomial whose roots are 2,4 and 6. The first five sequences it produces are:
{0, 0, 0, 0, 0, 0}, {1, 6, 1, 6, 1, 6}, {2, 5, 2, 5, 2, 5}, {3, 4, 3, 4, 3, 4}, {4, 3, 4, 3, 4, 3}, …
I have two questions:
i) The first sequence is obtained when i=0,j=0,k=0; the second when i=0,j=0,k=1, the third when i=0,j=0,k=2, etc. Is there a way to join these numbers with the sequence they generate so that I will get to know these parameters and therefore to be able to, later (if needed), generate a particular sequence? That is I would like that the output would be something like this
{{0, 0, 0, 0, 0, 0}, {0, 0, 0}}, {{1, 6, 1, 6, 1, 6}, {0, 0, 1}}, {{2, 5, 2, 5, 2, 5}, {0, 0, 2}} , etc.
ii) In the example above (3rd order linear recurrence, and mod 7) the number of sequences obtained (216) is manageable by hand; but this number grows very quickly when the linear recurrence has order higher than 3 and the field has characteristic higher than 7. And, in those cases, most of the sequences that are produced are of no interest to me. I think that I could throw away at least 99% of the sequences that do not interest me if I could add an instruction that would read the output (the sequences obtained) and would say “I only want the sequences such that the products of its elements is 216 (say)”: from the five sequences above only {1, 6, 1, 6, 1, 6} would remain because 1x6x1x6x1x6=216$; or “I only want the sequences such that the products of its elements is 216 or 1000 (say)” from the five sequences above {1, 6, 1, 6, 1, 6} and {2, 5, 2, 5, 2, 5} would remain because 1x6x1x6x1x6 = 216 and 2x5x2x5x2x 5=1000.
Is it possible to do this? I tried some list and tables manipulation, but had no success.
Thank you in advance.
here is the first part..
Flatten[Table[{Table[Mod[i*2^n + j*4^n + k*6^n, 7], {n, 0, 5}], {i, j,
k}}, {i, 0, 5}, {j, 0, 5}, {k, 0, 5}], 2]
{{{0, 0, 0, 0, 0, 0}, {0, 0, 0}}, {{1, 6, 1, 6, 1, 6}, {0, 0,
1}}, {{2, 5, 2, 5, 2, 5}, {0, 0, 2}}, {{3, 4, 3, 4, 3, 4}, {0, 0,
3}},...
better way:
{Table[Mod[#.{2, 4, 6}^n, 7], {n, 0, 5}],#} & /# Tuples[Range[0, 5], {3}]
example finding cases with a specified product:
Reap[Do[
s = Table[Mod[i*2^n + j*4^n + k*6^n, 7], {n, 0, 5}];
If[Times ## s == 81, Sow[{s, {i, j, k}}]],
{i, 0, 5}, {j, 0, 5}, {k, 0, 5}]][[2, 1]]
{{{3, 3, 1, 3, 3, 1}, {1, 2, 0}}, {{3, 1, 3, 3, 1, 3}, {2, 1,
0}}, {{1, 3, 3, 1, 3, 3}, {4, 4, 0}}}

Compare (and) insert (in) from a position std::array

I have a std::array with several items and I want to compare it from a certain position and also insert in a certain position, for example.
std::array<int, 10> numbers {{ 9, 5, 6, 4, 5, 6, 1, 10, 15, 25 }};
I want to compare the array numbers from item 5 until the last one, with this one, from the beginning, that is position 0 until position 4.
std::array<int, 10> compare {{ 6, 1, 10, 15, 25, 0, 0, 0, 0, 0 }};
It will (in this case) return true.
And how to insert items from a position? I want to insert on the array compare from the position 5 until the last position, that is 9.
For example, if I want to insert these numbers: 5, 45, 32, 14, 10. It will turn:
std::array<int, 10> compare {{ 6, 1, 10, 15, 25, 5, 45, 32, 14, 10 }};
Thanks in advance.

Optimally picking one element from each list

I came across an old problem that you Mathematica/StackOverflow folks will probably like and that seems valuable to have on StackOverflow for posterity.
Suppose you have a list of lists and you want to pick one element from each and put them in a new list so that the number of elements that are identical to their next neighbor is maximized.
In other words, for the resulting list l, minimize Length#Split[l].
In yet other words, we want the list with the fewest interruptions of identical contiguous elements.
For example:
pick[{ {1,2,3}, {2,3}, {1}, {1,3,4}, {4,1} }]
--> { 2, 2, 1, 1, 1 }
(Or {3,3,1,1,1} is equally good.)
Here's a preposterously brute force solution:
pick[x_] := argMax[-Length#Split[#]&, Tuples[x]]
where argMax is as described here:
posmax: like argmax but gives the position(s) of the element x for which f[x] is maximal
Can you come up with something better?
The legendary Carl Woll nailed this for me and I'll reveal his solution in a week.
Not an answer, but a comparison of the methods proposed here. I generated test sets with a variable number of subsets this number varying from 5 to 100. Each test set was generated with this code
Table[RandomSample[Range[10], RandomInteger[{1, 7}]], {rl}]
with rl the number of subsets involved.
For every test set that was generated this way I had all the algorithms do their thing. I did this 10 times (with the same test set) with the algorithms operating in a random order so as to level out order effects and the effects of random background processes on my laptop. This results in mean timing for the given data set. The above line was used 20 times for each rl length, from which a mean (of means) and a standard deviation were calculated.
The results are below (horizontally the number of subsets and vertically the mean AbsoluteTiming):
It seems that Mr.Wizard is the (not so clear) winner. Congrats!
Update
As requested by Timo here the timings as a function of the number of distinct subset elements that can be chosen from as well as the maximum number of elements in each subset. The data sets are generated for a fixed number of subsets (50) according to this line of code:
lst = Table[RandomSample[Range[ch], RandomInteger[{1, ch}]], {50}];
I also increased the number of datasets I tried for each value from 20 to 40.
Here for 5 subsets:
I'll toss this into the ring. I am not certain it always gives an optimal solution, but it appears to work on the same logic as some other answers given, and it is fast.
f#{} := (Sow[m]; m = {i, 1})
f#x_ := m = {x, m[[2]] + 1}
findruns[lst_] :=
Reap[m = {{}, 0}; f[m[[1]] ⋂ i] ~Do~ {i, lst}; Sow#m][[2, 1, 2 ;;]]
findruns gives run-length-encoded output, including parallel answers. If output as strictly specified is required, use:
Flatten[First[#]~ConstantArray~#2 & ### #] &
Here is a variation using Fold. It is faster on some set shapes, but a little slower on others.
f2[{}, m_, i_] := (Sow[m]; {i, 1})
f2[x_, m_, _] := {x, m[[2]] + 1}
findruns2[lst_] :=
Reap[Sow#Fold[f2[#[[1]] ⋂ #2, ##] &, {{}, 0}, lst]][[2, 1, 2 ;;]]
This is my take on it, and does pretty much the same thing as Sjoerd, just in a less amount of code.
LongestRuns[list_List] :=
Block[{gr, f = Intersection},
ReplaceRepeated[
list, {a___gr, Longest[e__List] /; f[e] =!= {}, b___} :> {a,
gr[e], b}] /.
gr[e__] :> ConstantArray[First[f[e]], Length[{e}]]]
Some gallery:
In[497]:= LongestRuns[{{1, 2, 3}, {2, 3}, {1}, {1, 3, 4}, {4, 1}}]
Out[497]= {{2, 2}, {1, 1, 1}}
In[498]:= LongestRuns[{{3, 10, 6}, {8, 2, 10, 5, 9, 3, 6}, {3, 7, 10,
2, 8, 5, 9}, {6, 9, 1, 8, 3, 10}, {1}, {2, 9, 4}, {9, 5, 2, 6, 8,
7}, {6, 9, 4, 5}}]
Out[498]= {{3, 3, 3, 3}, {1}, {9, 9, 9}}
In[499]:= pickPath[{{3, 10, 6}, {8, 2, 10, 5, 9, 3, 6}, {3, 7, 10, 2,
8, 5, 9}, {6, 9, 1, 8, 3, 10}, {1}, {2, 9, 4}, {9, 5, 2, 6, 8,
7}, {6, 9, 4, 5}}]
Out[499]= {{10, 10, 10, 10}, {{1}, {9, 9, 9}}}
In[500]:= LongestRuns[{{2, 8}, {4, 2}, {3}, {9, 4, 6, 8, 2}, {5}, {8,
10, 6, 2, 3}, {9, 4, 6, 3, 10, 1}, {9}}]
Out[500]= {{2, 2}, {3}, {2}, {5}, {3, 3}, {9}}
In[501]:= LongestRuns[{{4, 6, 18, 15}, {1, 20, 16, 7, 14, 2, 9}, {12,
3, 15}, {17, 6, 13, 10, 3, 19}, {1, 15, 2, 19}, {5, 17, 3, 6,
14}, {5, 17, 9}, {15, 9, 19, 13, 8, 20}, {18, 13, 5}, {11, 5, 1,
12, 2}, {10, 4, 7}, {1, 2, 14, 9, 12, 3}, {9, 5, 19, 8}, {14, 1, 3,
4, 9}, {11, 13, 5, 1}, {16, 3, 7, 12, 14, 9}, {7, 4, 17, 18,
6}, {17, 19, 9}, {7, 15, 3, 12}, {19, 12, 5, 14, 8}, {1, 10, 12,
8}, {18, 16, 14, 19}, {2, 7, 10}, {19, 2, 5, 3}, {16, 17, 3}, {16,
2, 6, 20, 1, 3}, {12, 18, 11, 19, 17}, {12, 16, 9, 20, 4}, {19, 20,
10, 12, 9, 11}, {10, 12, 6, 19, 17, 5}}]
Out[501]= {{4}, {1}, {3, 3}, {1}, {5, 5}, {13, 13}, {1}, {4}, {9, 9,
9}, {1}, {7, 7}, {9}, {12, 12, 12}, {14}, {2, 2}, {3, 3}, {12, 12,
12, 12}}
EDIT given that Sjoerd's Dreeves's brute force approach fails on large samples due to inability to generate all Tuples at once, here is another brute force approach:
bfBestPick[e_List] := Block[{splits, gr, f = Intersection},
splits[{}] = {{}};
splits[list_List] :=
ReplaceList[
list, {a___gr, el__List /; f[el] =!= {},
b___} :> (Join[{a, gr[el]}, #] & /# splits[{b}])];
Module[{sp =
Cases[splits[
e] //. {seq__gr,
re__List} :> (Join[{seq}, #] & /# {re}), {__gr}, Infinity]},
sp[[First#Ordering[Length /# sp, 1]]] /.
gr[args__] :> ConstantArray[First[f[args]], Length[{args}]]]]
This brute-force-best-pick might generate different splitting, but it is length that matters according to the original question.
test = {{4, 6, 18, 15}, {1, 20, 16, 7, 14, 2, 9}, {12, 3, 15}, {17, 6,
13, 10, 3, 19}, {1, 15, 2, 19}, {5, 17, 3, 6, 14}, {5, 17,
9}, {15, 9, 19, 13, 8, 20}, {18, 13, 5}, {11, 5, 1, 12, 2}, {10,
4, 7}, {1, 2, 14, 9, 12, 3}, {9, 5, 19, 8}, {14, 1, 3, 4, 9}, {11,
13, 5, 1}, {16, 3, 7, 12, 14, 9}, {7, 4, 17, 18, 6}, {17, 19,
9}, {7, 15, 3, 12}, {19, 12, 5, 14, 8}, {1, 10, 12, 8}, {18, 16,
14, 19}, {2, 7, 10}, {19, 2, 5, 3}, {16, 17, 3}, {16, 2, 6, 20, 1,
3}, {12, 18, 11, 19, 17}, {12, 16, 9, 20, 4}, {19, 20, 10, 12, 9,
11}, {10, 12, 6, 19, 17, 5}};
pick fails on this example.
In[637]:= Length[bfBestPick[test]] // Timing
Out[637]= {58.407, 17}
In[638]:= Length[LongestRuns[test]] // Timing
Out[638]= {0., 17}
In[639]:=
Length[Cases[pickPath[test], {__Integer}, Infinity]] // Timing
Out[639]= {0., 17}
I am posting this in case somebody might want to search for counterexamples that the code like pickPath or LongestRuns does indeed generate a sequence with smallest number of interruptions.
Here's a go at it...
runsByN: For each number, show whether it appears or not in each sublist
list= {{4, 2, 7, 5, 1, 9, 10}, {10, 1, 8, 3, 2, 7}, {9, 2, 7, 3, 6, 4, 5}, {10, 3, 6, 4, 8, 7}, {7}, {3, 1, 8, 2, 4, 7, 10, 6}, {7, 6}, {10, 2, 8, 5, 6, 9, 7, 3}, {1, 4, 8}, {5, 6, 1}, {3, 2, 1}, {10,6, 4}, {10, 7, 3}, {10, 2, 4}, {1, 3, 5, 9, 7, 4, 2, 8}, {7, 1, 3}, {5, 7, 1, 10, 2, 3, 6, 8}, {10, 8, 3, 6, 9, 4, 5, 7}, {3, 10, 5}, {1}, {7, 9, 1, 6, 2, 4}, {9, 7, 6, 2}, {5, 6, 9, 7}, {1, 5}, {1,9, 7, 5, 4}, {5, 4, 9, 3, 1, 7, 6, 8}, {6}, {10}, {6}, {7, 9}};
runsByN = Transpose[Table[If[MemberQ[#, n], n, 0], {n, Max[list]}] & /# list]
Out = {{1, 1, 0, 0, 0, 1, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 1, 1, 0, 0,1, 1, 1, 0, 0, 0, 0}, {2, 2, 2, 0, 0, 2, 0, 2, 0, 0, 2, 0, 0, 2, 2,0, 2, 0, 0, 0, 2, 2, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 3, 3, 3, 0, 3, 0,3, 0, 0, 3, 0, 3, 0, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0,0}, {4, 0, 4, 4, 0, 4, 0, 0, 4, 0, 0, 4, 0, 4, 4, 0, 0, 4, 0, 0, 4, 0, 0, 0, 4, 4, 0, 0, 0, 0}, {5, 0, 5, 0, 0, 0, 0, 5, 0, 5, 0, 0, 0, 0, 5, 0, 5, 5, 5, 0, 0, 0, 5, 5, 5, 5, 0, 0, 0, 0}, {0, 0, 6, 6, 0, 6, 6, 6, 0, 6, 0, 6, 0, 0, 0, 0, 6, 6, 0, 0, 6, 6, 6, 0, 0, 6, 6, 0,6, 0}, {7, 7, 7, 7, 7, 7, 7, 7, 0, 0, 0, 0, 7, 0, 7, 7, 7, 7, 0, 0, 7, 7, 7, 0, 7, 7, 0, 0, 0, 7}, {0, 8, 0, 8, 0, 8, 0, 8, 8, 0, 0, 0, 0, 0, 8, 0, 8, 8, 0, 0, 0, 0, 0, 0, 0, 8, 0, 0, 0, 0}, {9, 0, 9, 0, 0, 0, 0, 9, 0, 0, 0, 0, 0, 0, 9, 0, 0, 9, 0, 0, 9, 9, 9, 0, 9, 9, 0, 0, 0, 9}, {10, 10, 0, 10, 0, 10, 0, 10, 0, 0, 0, 10, 10, 10, 0, 0, 10, 10, 10, 0, 0, 0, 0, 0, 0, 0, 0, 10, 0, 0}};
runsByN is list transposed, with zeros inserted to represent missing numbers. It shows the sublists in which 1, 2, 3, and 4 appeared.
myPick: Picking numbers that constitute an optimal path
myPick recursively builds a list of the longest runs. It doesn't look for all optimal solutions, but rather the first solution of minimal length.
myPick[{}, c_] := Flatten[c]
myPick[l_, c_: {}] :=
Module[{r = Length /# (l /. {x___, 0, ___} :> {x}), m}, m = Max[r];
myPick[Cases[(Drop[#, m]) & /# l, Except[{}]],
Append[c, Table[Position[r, m, 1, 1][[1, 1]], {m}]]]]
choices = myPick[runsByN]
(* Out= {7, 7, 7, 7, 7, 7, 7, 7, 1, 1, 1, 10, 10, 10, 3, 3, 3, 3, 3, 1, 1, 6, 6, 1, 1, 1, 6, 10, 6, 7} *)
Thanks to Mr.Wizard for suggesting the use of a replacement rule as an efficient alternative to TakeWhile.
Epilog:Visualizing the solution path
runsPlot[choices1_, runsN_] :=
Module[{runs = {First[#], Length[#]} & /# Split[choices1], myArrow,
m = Max[runsN]},
myArrow[runs1_] :=
Module[{data1 = Reverse#First[runs1], data2 = Reverse[runs1[[2]]],
deltaX},
deltaX := data2[[1]] - 1;
myA[{}, _, out_] := out;
myA[inL_, deltaX_, outL_] :=
Module[{data3 = outL[[-1, 1, 2]]},
myA[Drop[inL, 1], inL[[1, 2]] - 1,
Append[outL, Arrow[{{First[data3] + deltaX,
data3[[2]]}, {First[data3] + deltaX + 1, inL[[1, 1]]}}]]]];
myA[Drop[runs1, 2], deltaX, {Thickness[.005],
Arrow[{data1, {First[data1] + 1, data2[[2]]}}]}]];
ListPlot[runsN,
Epilog -> myArrow[runs],
PlotStyle -> PointSize[Large],
Frame -> True,
PlotRange -> {{1, Length[choices1]}, {1, m}},
FrameTicks -> {All, Range[m]},
PlotRangePadding -> .5,
FrameLabel -> {"Sublist", "Number", "Sublist", "Number"},
GridLines :> {FoldList[Plus, 0, Length /# Split[choices1]], None}
]];
runsPlot[choices, runsByN]
The chart below represents the data from list.
Each plotted point corresponds to a number and the sublist in which it occurred.
So here is my "one liner" with improvements by Mr.Wizard:
pickPath[lst_List] :=
Module[{M = Fold[{#2, #} &, {{}}, Reverse#lst]},
Reap[While[M != {{}},
Do[Sow##[[-2,1]], {Length## - 1}] &#
NestWhileList[# ⋂ First[M = Last#M] &, M[[1]], # != {} &]
]][[2, 1]]
]
It basically uses intersection repeatedly on consecutive lists until it comes up empty, and then does it again and again. In a humongous torture test case with
M = Table[RandomSample[Range[1000], RandomInteger[{1, 200}]], {1000}];
I get Timing[] consistently around 0.032 on my 2GHz Core 2 Duo.
Below this point is my first attempt, which I'll leave for your perusal.
For a given list of lists of elements M we count the different elements and the number of lists, list the different elements in canonical order, and construct a matrix K[i,j] detailing the presence of element i in list j:
elements = Length#(Union ## M);
lists = Length#M;
eList = Union ## M;
positions = Flatten#Table[{i, Sequence ## First#Position[eList, M[[i,j]]} -> 1,
{i, lists},
{j, Length#M[[i]]}];
K = Transpose#Normal#SparseArray#positions;
The problem is now equivalent to traversing this matrix from left to right, by only stepping on 1's, and changing rows as few times as possible.
To achieve this I Sort the rows, take the one with the most consecutive 1's at the start, keep track of what element I picked, Drop that many columns from K and repeat:
R = {};
While[Length#K[[1]] > 0,
len = LengthWhile[K[[row = Last#Ordering#K]], # == 1 &];
Do[AppendTo[R, eList[[row]]], {len}];
K = Drop[#, len] & /# K;
]
This has an AbsoluteTiming of approximately three times that of Sjoerd's approach.
My solution is based on the observation that 'greed is good' here. If I have the choice between interrupting a chain and beginning a new, potentially long chain, picking the new one to continue doesn't do me any good. The new chain gets longer with the same amount as the old chain gets shorter.
So, what the algorithm basically does is starting at the first sublist and for each of its members finding the number of additional sublists that have the same member and choosing the sublist member that has the most neighboring twins. This process then continues at the sublist at the end of this first chain and so on.
So combining this in a recursive algorithm we end up with:
pickPath[lst_] :=
Module[{lengthChoices, bestElement},
lengthChoices =
LengthWhile[lst, Function[{lstMember}, MemberQ[lstMember, #]]] & /#First[lst];
bestElement = Ordering[lengthChoices][[-1]];
If[ Length[lst] == lengthChoices[[bestElement]],
ConstantArray[lst[[1, bestElement]], lengthChoices[[bestElement]]],
{
ConstantArray[lst[[1, bestElement]], lengthChoices[[bestElement]]],
pickPath[lst[[lengthChoices[[bestElement]] + 1 ;; -1]]]
}
]
]
Test
In[12]:= lst =
Table[RandomSample[Range[10], RandomInteger[{1, 7}]], {8}]
Out[12]= {{3, 10, 6}, {8, 2, 10, 5, 9, 3, 6}, {3, 7, 10, 2, 8, 5,
9}, {6, 9, 1, 8, 3, 10}, {1}, {2, 9, 4}, {9, 5, 2, 6, 8, 7}, {6, 9,
4, 5}}
In[13]:= pickPath[lst] // Flatten // AbsoluteTiming
Out[13]= {0.0020001, {10, 10, 10, 10, 1, 9, 9, 9}}
Dreeves' Brute Force approach
argMax[f_, dom_List] :=
Module[{g}, g[e___] := g[e] = f[e];(*memoize*) dom[[Ordering[g /# dom, -1]]]]
pick[x_] := argMax[-Length#Split[#] &, Tuples[x]]
In[14]:= pick[lst] // AbsoluteTiming
Out[14]= {0.7340420, {{10, 10, 10, 10, 1, 9, 9, 9}}}
The first time I used a slightly longer test list. The brute force approach brought my computer to a virtual standstill, claiming all the memory it had. Pretty bad. I had to restart after 10 minutes. Restarting took me another quarter, due to the PC becoming extremely non-responsive.
Could use integer linear programming. Here is code for that.
bestPick[lists_] := Module[
{picks, span, diffs, v, dv, vars, diffvars, fvars,
c1, c2, c3, c4, constraints, obj, res},
span = Max[lists] - Min[lists];
vars = MapIndexed[v[Sequence ## #2] &, lists, {2}];
picks = Total[vars*lists, {2}];
diffs = Differences[picks];
diffvars = Array[dv, Length[diffs]];
fvars = Flatten[{vars, diffvars}];
c1 = Map[Total[#] == 1 &, vars];
c2 = Map[0 <= # <= 1 &, fvars];
c3 = Thread[span*diffvars >= diffs];
c4 = Thread[span*diffvars >= -diffs];
constraints = Join[c1, c2, c3, c4];
obj = Total[diffvars];
res = Minimize[{obj, constraints}, fvars, Integers];
{res[[1]], Flatten[vars*lists /. res[[2]] /. 0 :> Sequence[]]}
]
Your example:
lists = {{1, 2, 3}, {2, 3}, {1}, {1, 3, 4}, {4, 1}}
bestPick[lists]
Out[88]= {1, {2, 2, 1, 1, 1}}
For larger problems Minimize might run into trouble since it uses exact methods for solving relaxed LPs. In which case you might need to switch to NMinimize, and change the domain argument to a constraint of the form Element[fvars,Integers].
Daniel Lichtblau
A week is up! Here is the fabled solution from Carl Woll. (I tried to get him to post it himself. Carl, if you come across this and want to take official credit, just paste it in as a separate answer and I'll delete this one!)
pick[data_] := Module[{common,tmp},
common = {};
tmp = Reverse[If[(common = Intersection[common,#])=={}, common = #, common]& /#
data];
common = .;
Reverse[If[MemberQ[#, common], common, common = First[#]]& /# tmp]]
Still quoting Carl:
Basically, you start at the beginning, and find the element which gives you
the longest string of common elements. Once the string can no longer be
extended, start a new string. It seems to me that this algorithm ought to
give you a correct answer (there are many correct answers).