4
$\begingroup$

I have a list and a order

list = {{{357, 120}, {271, 78}}, {{239, 90}, {259, 77}}, {{259, 
     71}, {165, 25}}, {{271, 70}, {337, 30}}};
order = {{259, 77}, {259, 71}, {271, 78}, {271, 70}};

So any beautiful method to sort the list by order?The current method is look sounds clumsy:

Catenate@MapThread[
  Complement, {Catenate[Select[list, MemberQ[#]] & /@ order], 
   List /@ order}]

{{239, 90}, {165, 25}, {357, 120}, {337, 30}}

$\endgroup$
4
  • $\begingroup$ Could you clarify exactly how the input and output are related? It appears that the list is a list of pairs, and the order contains one element from each pair in some order, and you want the corresponding element from all of those pairs in list, is that correct? $\endgroup$ Mar 18, 2016 at 9:48
  • $\begingroup$ @MartinBüttner The list's every element (list of pairs) contain a element of order. $\endgroup$
    – yode
    Mar 18, 2016 at 9:52
  • $\begingroup$ Belated Happy 10K! $\endgroup$
    – Michael E2
    Jan 6, 2019 at 20:54
  • $\begingroup$ @MichaelE2 Thanks. It is not too easy for me indeed. :) $\endgroup$
    – yode
    Jan 9, 2019 at 3:49

3 Answers 3

8
$\begingroup$

If I'm understanding your question correctly, something like this would work:

list = {{{357, 120}, {271, 78}}, {{239, 90}, {259, 77}}, {{259, 
     71}, {165, 25}}, {{271, 70}, {337, 30}}};
order = {{259, 77}, {259, 71}, {271, 78}, {271, 70}};

SelectFirst[
  SelectFirst[list, MemberQ[#]],
  UnequalTo[#]
] & /@ order

(* {{239, 90}, {165, 25}, {357, 120}, {337, 30}} *)

The inner SelectFirst picks out the pair from list which contains the current element in order. The outer SelectFirst then chooses the element which is not equal to the one in order.

As Jason B points out, UnequalTo is a new addition in 10.4. In 10.3 you could use Not @* EqualTo[#] instead, but before that you'll have to use a closure or something like that:

With[{elem = #},
  SelectFirst[
    SelectFirst[list, MemberQ[#]],
    # != elem &
  ]
] & /@ order

Alternatively, a simple pattern-based approach:

FirstCase[list, {a_, #} | {#, a_} :> a] & /@ order

(* {{239, 90}, {165, 25}, {357, 120}, {337, 30}} *)

This second approach is actually a bit faster, in case you want to handle large lists:

list = RandomInteger[400, {2000, 2, 2}];
order = RandomSample[RandomChoice /@ list];
RepeatedTiming[
  SelectFirst[
    SelectFirst[list, MemberQ[#]],
    UnequalTo[#]
  ] & /@ order;
]
(* {4.04, Null} *)

RepeatedTiming[
  FirstCase[list, {a_, #} | {#, a_} :> a] & /@ order;
]
(* {2.682, Null} *)
$\endgroup$
3
  • $\begingroup$ God!How terse(I just now learned this word) the code is! $\endgroup$
    – yode
    Mar 18, 2016 at 9:56
  • 2
    $\begingroup$ In case you are using version 10.3, you need to replace UnequalTo[#] with Not@*EqualTo[#]. If before 10.3, probably another construction is needed $\endgroup$
    – Jason B.
    Mar 18, 2016 at 10:12
  • $\begingroup$ @JasonB Oh good point. In that case I might just go with a closure and do elem != # &. I'll edit that into the answer. $\endgroup$ Mar 18, 2016 at 10:15
4
$\begingroup$

Here are two variants on the same idea of using Nearest. The first is a little faster on small lists and on large lists. They're about the same on @Martin Ender's example in his answer.

Flatten[Nearest[Join[#1, #2] -> Join[#2, #1] & @@ Transpose@list,
  order, {1, 0}], 1]
Flatten[Nearest[Flatten[list, 1] -> Flatten[Reverse /@ list, 1],
  order, {1, 0}], 1]
(*
  {{239, 90}, {165, 25}, {357, 120}, {337, 30}}
  {{239, 90}, {165, 25}, {357, 120}, {337, 30}}
*)

Timings on @Martin Ender's example. Note that the uniqueness of the result depends on the uniqueness of the sorting keys in order. For RandomInteger[400, {2000, 2, 2}] with SeedRandom[0], the keys were not unique, so I increased the size of the integers to make them so.

SeedRandom[0];
list = RandomInteger[4000, {2000, 2, 2}];
order = RandomSample[RandomChoice /@ list];

foo1 = Flatten[
    Nearest[Join[#1, #2] -> Join[#2, #1] & @@ Transpose@list, 
     order, {1, 0}], 1]; // RepeatedTiming

foo2 = Flatten[Nearest[Flatten[list, 1] -> Flatten[Reverse /@ list, 1],
     order, {1, 0}], 1]; // RepeatedTiming

foo3 = FirstCase[list, {a_, #} | {#, a_} :> a] & /@  (* Martin Ender's faster one *)
    order; // RepeatedTiming

foo1 == foo2 == foo3

(*
  {0.0024, Null}
  {0.0024, Null}
  {1.955, Null}
  True
*)

Addendum. Note that part of the slowness of FirstCase is that it unpacks list (repeatedly). A single unpacking of list does not take that much time compared to the overall time. It makes a difference whether the call to FirstCase[] is by reference to the stored array, listup below, or is directly on the output of FromPackedArray. It seems in the latter case, the array is repacked and we're back to situation above, FirstCase[list,...]. Even weirder is the case where the array is unpacked to level 1. There were many warnings from On@"Packing" of unpacking to level 1, so I thought I'd see if an unpacked list of packed arrays might be faster. Instead it was much slower. Further, it depends on how it's unpacked, whether it's unpack and repacked at level 1 or simply unpacked with {##} & @@ list. The unpacking and repacking takes very little time. I'm not sure why the speed is so slow, but I thought it was worth pointing out. There is a similar difference whether FirstCase[] is called on an array stored in a symbol or the direct output of a function.

(* Completely unpacked *)
(listup = Developer`FromPackedArray@list;
   FirstCase[listup, {a_, #} | {#, a_} :> a] & /@ order); // RepeatedTiming
FirstCase[Developer`FromPackedArray[list], {a_, #} | {#, a_} :> a] & /@
    order; // RepeatedTiming
(*
  {0.604, Null}
  {1.9, Null}
*)

(* Unpacked to level 1 *)
(murf = {##} & @@ list;   (* store in murf *)
   FirstCase[murf, {a_, #} | {#, a_} :> a] & /@ order); // RepeatedTiming
FirstCase[                (* not stored in variable *)
     {##} & @@ list,
     {a_, #} | {#, a_} :> a] & /@ order; // RepeatedTiming
FirstCase[                (* unpacked & repacked below level 1 *)
     With[{opts = SystemOptions["CompileOptions"]},
      Internal`WithLocalSettings[
       SetSystemOptions["CompileOptions" -> "MapCompileLength" -> Infinity],
       Developer`ToPackedArray /@ Developer`FromPackedArray[list],
       SetSystemOptions[opts]
       ]],
     {a_, #} | {#, a_} :> a] & /@ order; // RepeatedTiming
(*
  {1.37, Null}
  {2.0, Null}
  {5.7, Null}
*)
$\endgroup$
1
  • $\begingroup$ Lookup[AssociationThread[Join[#1, #2] -> Join[#2, #1] & @@ Transpose@list], order] is a little slower than the Nearest solution, taking a little less than twice as long. $\endgroup$
    – Michael E2
    Jan 8, 2019 at 21:53
1
$\begingroup$

Thanks for that, Michael E2. Super impressive performance with Nearest[ ]!

Sharing this for information, as an experiment with SortBy[ ]. Starting with the big data set

SeedRandom[0];
list = RandomInteger[4000, {2000, 2, 2}];
order = RandomSample[RandomChoice /@ list]; 

Tried the problem using SortBy[ ] and here is the kernel of it (skipping the bookwork on picking off the non-matching elements)

SortBy[list, (Position[order, #[[1]] |  #[[2]]]) &]; // RepeatedTiming

1.9

Most of that was computing the Position, it appears

Map[(Position[order, #[[1]] |  #[[2]]]) &, list]; // RepeatedTiming

1.887

Here's my full version and Martin Enders' The Nearest version is too cheap to meter.

foo3 = FirstCase[list, {a_, #} | {#, a_} :> a] & /@(*Martin Ender's faster one*)
order; // RepeatedTiming

foo4 = MapThread[(Complement[#1, {#2}] // First) &, 
                     {SortBy[list, (Position[order,#[[1]] | #[[2]]]) &],order}
                ]; // RepeatedTiming

2.12

1.87

$\endgroup$

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.