7
$\begingroup$

I am working on some simple problem. It is like puzzle..

Let's say I have some list

input={{1,1},{1,2},{1,3},{2,3},{3,3},{4,4}}

Which means 1 can go and back to 1 (<->), 1<->2, 1<->3, 2<->3,3<->3 4<->4. So I want to make some groups that can go and back, by grouping the elements if there is any connection

(*wishing*)output={{1,2,3},{4}}

Here is how I tried, it is little complicated way, and I could not finish this.. Sorry for messy code.

Do[g[i] = {}, {i, 1, Length[input]}];

out=Table[Table[
   If[input[[i, 1]] == input[[a, 1]], g[i] = Append[g[i], input[[a, 2]]]]
   , {a, 1, Length[input]}]
  , {i, 1, Length[input]}] /. Null -> Sequence[]

and I got

Table[Union[Flatten[out[[i]]]], {i, 1, Length[out]}]
{{1, 2, 3}, {1, 2, 3}, {1, 2, 3}, {3}, {3}, {4}}

So

Union[%]
{{3}, {4}, {1, 2, 3}}

Which is almost... what I want to get, but I cannot... get what I want to get. I might be able to make it even masseir code.. but anyone have any tip?

Improve this question
$\endgroup$
2
  • $\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
    Oct 7, 2015 at 23:33
  • $\begingroup$ I am sorry, I did not know that you will answer that so quickly, Thank you for your comment! $\endgroup$
    – Saesun Kim
    Oct 8, 2015 at 4:45

2 Answers 2

Reset to default
11
$\begingroup$ 
input = {{1, 1}, {1, 2}, {1, 3}, {2, 3}, {3, 3}, {4, 4}};
ConnectedComponents@Graph[UndirectedEdge @@@ input]
(*  {{3, 1, 2}, {4}} *)
Improve this answer
$\endgroup$
4
  • 3
    $\begingroup$ Your one-liner graph-theoretic answers always make me smile, +1. $\endgroup$
    – ciao
    Oct 8, 2015 at 1:03
  • 2
    $\begingroup$ Yep; that's the correct solution. $\endgroup$
    – march
    Oct 8, 2015 at 1:08
  • 1
    $\begingroup$ @ciao That's probably my main reason for hanging around :) $\endgroup$
    – Dr. belisarius
    Oct 8, 2015 at 2:31
  • $\begingroup$ @user3002626 Please remember to accept one answer (no matter if it takes you a few days, but please don't leave the question "orphan") $\endgroup$
    – Dr. belisarius
    Oct 8, 2015 at 13:58
1
$\begingroup$

Here is a solution that is 1000 times slower than belisarius's and is likely to scale terribly. I post it only for the purpose of illustrating that a "transparent" approach can be easily implemented in one line in Mathematica (transparent meaning that the actual steps taken are basically shown, unlike the graph-theoretic function approach, which hides some of the algorithms under the hood; as belisarius once told me:

The main problem when programming in Mma is finding a way without programming.

which is why their solution is so much better).

input = {{1, 1}, {1, 2}, {1, 3}, {2, 3}, {3, 3}, {4, 4}};
FixedPoint[Union@@@Gather[#, ! DisjointQ[#1, #2] &] &, input]
(* {{1, 2, 3}, {4}} *)

The function Gather[#, ! DisjointQ[#1, #2] &] separates the list into sublists in which the elements fed pairwise to the function ! DisjointQ[#1, #2] & yield True. For instance,

! DisjointQ[#1, #2] & @@ {{1, 1}, {1, 2}}
! DisjointQ[#1, #2] & @@ {{1, 1}, {4, 4}}
(* True *)
(* False *)

On a single pass, he function Gather won't collect all the pairs together that need to be paired:

Gather[#, ! DisjointQ[#1, #2] &] & @ inputs
(* {{{1, 1}, {1, 2}, {1, 3}}, {{2, 3}, {3, 3}}, {{4, 4}}} *)

For this reason, we Apply Union to each of the sublists and try again:

Union@@@Gather[#, ! DisjointQ[#1, #2] &] & @ inputs
Union@@@Gather[#, ! DisjointQ[#1, #2] &] & @ %
(* {{1, 2, 3}, {2, 3}, {4}} *)
(* {{1, 2, 3}, {4}} *)

On longer lists with more than two connected components, it is likely that this will need to be run more than twice, which is why I employ FixedPointList to iteratively run Union@@@Gather[#, ! DisjointQ[#1, #2] &] & until all the connected points are gathered together. Part of the slowness of this method has to do with the fact that we run over the list multiple times.

For instance,

input = RandomInteger[{1, 1000}, {1000, 2}];
(* belisarius *)
ConnectedComponents@Graph[UndirectedEdge @@@ input]; // AbsoluteTiming
(* march *)
FixedPoint[Union @@@ Gather[#, ! DisjointQ[#1, #2] &] &, input]; // AbsoluteTiming
(* {0.001302, Null} *)
(* {3.513250, Null} *)
Improve this answer
$\endgroup$
2
  • $\begingroup$ Thank you for the answer, and I apology that I did not accept your answer.. I think your method is very helpful for me to understand mma. Thank you alot! $\endgroup$
    – Saesun Kim
    Oct 8, 2015 at 17:23
  • 1
    $\begingroup$ @user3002626. You don't need to apologize for accepting a much much better answer! $\endgroup$
    – march
    Oct 8, 2015 at 17:28

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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