11
$\begingroup$

I have a list of lists, and I want to eliminate all the lists that are constant integer multiples of another list. My initial approach was to divide the lists using nested tables.

ex1 = {{1, 1, 1}, {1, 1, 2}, {2, 2, 2}, {2, 2, 4}, {3, 3, 5}};
Table[Table[
    If[Subtract @@ MinMax[ex1[[j]]/ex1[[i]]] == 0, 
    ex1[[j]] = ex1[[i]]], {j, i + 1, Length[ex1]}], {i, Length[ex1]}];
Union[ex1]
{{1, 1, 1}, {1, 1, 2}, {3, 3, 5}}

However, some of my lists have zeroes, which breaks my code.

ex2 = {{1, 1, 0}, {1, 1, 2}, {2, 2, 0}, {2, 2, 4}, {3, 3, 5}};
Table[Table[
    If[Subtract @@ MinMax[ex2[[j]]/ex2[[i]]] == 0, 
    ex2[[j]] = ex2[[i]]], {j, i + 1, Length[ex2]}], {i, Length[ex2]}];
Union[ex2]
"CHAOS ENSUES"

I have an alternative approach which is stupid and ugly.

ex3 = {{1, 1, 0}, {1, 1, 2}, {2, 2, 0}, {2, 2, 4}, {3, 3, 5}};
Table[
    Table[
        Table[
            If[ex3[[i]]*k == ex3[[j]], ex3[[j]] = ex3[[i]]], {k, j}], 
    {j, i + 1, Length[ex3]}], 
{i, Length[ex3]}];
Union[ex3]
{{1, 1, 0}, {1, 1, 2}, {3, 3, 5}}

I'm certain there's a better way, but I can't come up with it. I was frustrated by the ugliness of with my first attempt, but at least it was somewhat clever. Can you suggest something nicer?

$\endgroup$

5 Answers 5

9
$\begingroup$

GatherBy is much faster than the pairwise-compare of DeleteDuplicates with a custom comparator.

jm = DeleteDuplicates[#, Norm[Cross[##]] == 0 &] &;

gb = GatherBy[#, #/Max[1, GCD @@ #] &][[All, 1]] &;

Needs["GeneralUtilities`"]

BenchmarkPlot[{jm, gb}, RandomInteger[9, {#, 3}] &, 5, "IncludeFits" -> True]

enter image description here

Other examples:

$\endgroup$
2
  • $\begingroup$ If involves negative multiples, may not get the correct result. GatherBy[{{1,2,3},{2,4,6},{-2,-4,-6},{1,2,-3},{1,-2,3}},#/Max[1,GCD@@#]&] $\endgroup$
    – expression
    Nov 11, 2020 at 16:59
  • $\begingroup$ @expression Caveat noted. Thank you. $\endgroup$
    – Mr.Wizard
    Dec 3, 2020 at 20:47
11
$\begingroup$

Same principle as kglr's, but using a much cheaper test:

DeleteDuplicates[{{1, 1, 1}, {1, 1, 2}, {2, 2, 2}, {2, 2, 4}, {3, 3, 5}},
                 Norm[Cross[##]] == 0 &]
   {{1, 1, 1}, {1, 1, 2}, {3, 3, 5}}

For eliminating only integer multiples:

DeleteDuplicates[{{2, 2, 2}, {2, 2, 4}, {3, 3, 5}, {3, 3, 6}, {5, 5, 5}, {8, 8, 8}}, 
                 Norm[Cross[##]] == 0 &&
                 (And @@ Thread[Divisible[##] || Divisible[#2, #1]]) &]
   {{2, 2, 2}, {2, 2, 4}, {3, 3, 5}, {3, 3, 6}, {5, 5, 5}}
$\endgroup$
9
$\begingroup$

Update:

I want to eliminate all the lists that are constant integer multiples of another list.

As noted by Simon in a comment all the methods in my original answer eliminate rows that are rational multiples of another row.

To eliminate a row when it is an integer multiple of another row, we can use

ClearAll[f]
f = DeleteDuplicates[#, Reduce[# == k #2 || m # == #2, {k, m}, Integers] =!= False &]

or

f = DeleteDuplicates[#, Resolve[Exists[{k, m}, # == k #2 || m # == #2], Integers] &] &

Examples:

f @ ex1

{{1, 1, 1}, {1, 1, 2}, {3, 3, 5}}

ex2 = {{1, 1, 2}, {2, 2, 2}, {2, 2, 4}, {3, 3, 5}, {5, 5, 5}};
f @ ex2 

{{1, 1, 2}, {2, 2, 2}, {3, 3, 5}, {5, 5, 5}}

which is the correct result. The other methods posted so far all eliminate {5, 5, 5} in ex2 because it is a rational multiple of {2, 2, 2}:

DeleteDuplicates[ex2, MatrixRank@{##} == 1 &]

{{1, 1, 2}, {2, 2, 2}, {3, 3, 5}}

jm @ ex2 == gb @ ex2 == DeleteDuplicates[ex2, MatrixRank@{##} == 1 &]

True

Original answer:

DeleteDuplicates[ex1, MatrixRank @ {##} == 1 &]
DeleteDuplicates[ex1, Length @ SingularValueList @ {##} == 1 &]
DeleteDuplicates[ex1, RowReduce[{##}][[2]] == {0, 0, 0} &]

{{1, 1, 1}, {1, 1, 2}, {3, 3, 5}}

$\endgroup$
3
  • 1
    $\begingroup$ +1 because it's clever but doesn't this eliminate rows which are rational multiples of another row, not just integer multiples? $\endgroup$ Oct 13, 2017 at 20:26
  • $\begingroup$ @Simon, right... oops. Thank you for the vote. $\endgroup$
    – kglr
    Oct 13, 2017 at 20:39
  • $\begingroup$ @Simon, updated with a clunkier but, I think, correct method. $\endgroup$
    – kglr
    Oct 13, 2017 at 22:44
1
$\begingroup$

Just divide one list by the ratio of the first elements of each list. Then check if they’re equal

$\endgroup$
2
  • 1
    $\begingroup$ should work, but mind the zeros... maybe add some code? $\endgroup$
    – M. Stern
    Nov 10, 2017 at 2:00
  • $\begingroup$ Good point. This is an easy case to test— simply test if the first element of either list is zero. $\endgroup$
    – Paul
    Nov 10, 2017 at 2:02
0
$\begingroup$
SeedRandom[1]
mat = RandomInteger[{1, 100}, {10^5, 3}];

r1 = GatherBy[mat, #/Max[1, GCD @@ #] &][[All, 1]]; // AbsoluteTiming

r2 = GatherBy[mat, #/Tr@# &][[All, 1]]; // AbsoluteTiming

r1 == r2

{0.548749, Null}

{0.505526, Null}

True

$\endgroup$
1
  • $\begingroup$ Wouldn't that code break if you include 0's in your matrix? $\endgroup$
    – Lokdal
    Nov 10, 2017 at 13:53

This site is temporarily in read-only mode and not accepting new answers.

Not the answer you're looking for? Browse other questions tagged .