2
$\begingroup$

I have a nested list like this:

test1 = {{1, 3}, {1, 4}, {1, 7}, {2, 1}, {3, 5}, {4, 1}, {5, 2}, {6, 1}, {7, 6}}

I want to join the lists together depending on if the first element is equal to the last element as to end up with:

test2 = {{1, 3, 3, 5, 5, 2, 2, 1}, {1, 4, 4, 1}, {1, 7, 7, 6, 6, 1}}

Eventually I will want to delete duplicate elements in each list ending up with:

test3 = {{1, 3, 5, 2, 1}, {1, 4, 1}, {1, 7, 6, 1}}

I tried Join with constraints or GatherBy but I cant seem to get it right. Also note that first elements are always unique except if its a 1.

Any help is much appreciated!

$\endgroup$
  • $\begingroup$ What's the desired output for {{1, 2}, {2, 3}, {2, 4}, {2, 5}, {4, 2}}? $\endgroup$ – Szabolcs Jul 24 '15 at 7:37
  • $\begingroup$ The result in your example could also be {{1, 3}, {3, 5}, {5, 2}, {2, 1}, {1, 4}, {4, 1}, {1, 7}, {7, 6}, {6, 1}} in which case there is only one "partition". Please clarify. $\endgroup$ – Dr. belisarius Jul 24 '15 at 7:50
  • $\begingroup$ BTW the above was found by using FindPostmanTour@Graph[DirectedEdge @@@ test]. I mean, your first test definition. Please don't use the same symbol to refer to different things in your questions as it makes comments much difficult to write (like this one) $\endgroup$ – Dr. belisarius Jul 24 '15 at 7:52
  • $\begingroup$ thanks! just edited the question. FindPostmanTour@Graph[DirectedEdge @@@ test] seems to be doing what i wanted! Although it outputs "[DirectedEdge]" and not a list but that should be easy to rewrite. Thanks! $\endgroup$ – Pied Jul 24 '15 at 8:16
  • $\begingroup$ Welcome to Mathematica.SE! I suggest the following: 0) Browse the common pitfalls question 1) As you receive help, try to give it too, by answering questions in your area of expertise. 2) Read the faq! 3) When you see good questions and answers, vote them up by clicking the gray triangles, because the credibility of the system is based on the reputation gained by users sharing their knowledge. Also, please remember to accept the answer, if any, that solves your problem, by clicking the checkmark sign! $\endgroup$ – Dr. belisarius Jul 24 '15 at 12:14
4
$\begingroup$

Although I'd rather prefer to have a few more test cases at hand, I'm posting this as an answer since you confirmed in your comments that this does what you need.

test = {{1, 3}, {1, 4}, {1, 7}, {2, 1}, {3, 5}, {4, 1}, {5, 2}, {6, 1}, {7, 6}}
par = List @@@ First@FindPostmanTour@Graph[DirectedEdge @@@ test]
(*
{{1, 3}, {3, 5}, {5, 2}, {2, 1}, {1, 4}, {4, 1}, {1, 7}, {7, 6}, {6, 1}}
*)

of course

DeleteDuplicates@Flatten@par

Deletes your dups

$\endgroup$
  • $\begingroup$ Please note that FindPostmanTour will return an empty list if there is no "postman tour" $\endgroup$ – Dr. belisarius Jul 24 '15 at 8:37
  • 1
    $\begingroup$ +1, that was my first idea for it, but did not bother commenting/answering - I've got the sinking feeling a "...well, what I really need is for it to also handle these cases..." was there... $\endgroup$ – ciao Jul 24 '15 at 9:08
  • $\begingroup$ @ciao Yup. That feeling is a spreading disease these times :) $\endgroup$ – Dr. belisarius Jul 24 '15 at 12:09
1
$\begingroup$

Dirty code which does the job

test = {{1, 3}, {1, 4}, {1, 7}, {2, 1}, {3, 5}, {4, 1}, {5, 2}, {6, 1}, {7, 6}};

UberChain = {};
While[Length[test] > 1, chain = {test[[1]]};
  While[True, If[Last[Last[chain]] == First[First[chain]], Break[],
    AppendTo[chain, Select[test, #[[1]] == Last[Last[chain]] &][[1]]]]];
   Do[test = DeleteCases[test, chain[[i]]], {i, Length[chain]}];
  AppendTo[UberChain, chain]];
FinalUberChain = Map[DeleteDuplicates[Flatten[#]] &, UberChain]

Output:

{{1, 3, 5, 2}, {1, 4}, {1, 7, 6}}

This is a bit different then what you have given, because you said you want to delete duplicates on end and this is result of deleting duplicates (i.e. there can not be two 1's in final solution as it is shown in your last "test").

Code basically looks for element whose first member is same as last member of previous element. When it reaches the starting point, i.e. it would starting repeating it terminates and deletes the found members from the dataset (this is fair point by belisarius, it is not exactly clear what you wanted, but I guess this is what you want, looking at your final result). The procedure is then repeated until there are no more elements in the dataset. I have introduced different variable names (chain -> single list from one starting position, UberChain -> collection of all of these chains, FinalUberChain -> after deleting duplicates) so that things are not always called "test".

$\endgroup$
  • $\begingroup$ I've taken the liberty of adjusting your code. (By the way, Chain is a built-in variable in the units package, so I made it lower case.) $\endgroup$ – Chris Degnen Jul 24 '15 at 9:33
  • $\begingroup$ A great! Thanks, did not notice Chain problem. Adjusted my description also. $\endgroup$ – Neven Caplar Jul 24 '15 at 9:46
1
$\begingroup$
test1 = {{1, 3}, {1, 4}, {1, 7}, {2, 1}, {3, 5}, {4, 1}, {5, 2}, {6, 1}, {7, 6}};

f[{}] := {};

f[{a_, b_}] := Module[{c},
  c = Cases[test1, {b, _}];
  test1 = DeleteCases[test1, {a, b}, {1}, 1];
  If[c == {}, c,
   test1 = DeleteCases[test1, {b, _}, {1}, 1];
   First@c]];

test2 = {};

While[test1 != {},
 AppendTo[test2, Flatten@FixedPointList[f, First@test1]]];

test2
{{1, 3, 3, 5, 5, 2, 2, 1, 1, 4, 4, 1, 1, 7, 7, 6, 6, 1}}
test3 = test2 //. {a___, b_, b_, c___} :> {a, b, c}
{{1, 3, 5, 2, 1, 4, 1, 7, 6, 1}}

The above result corresponds to the order in which the nodes are visited, i.e.

Graph[First[FindPostmanTour@Graph[DirectedEdge @@@ test1]], 
 VertexLabels -> "Name"]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.