# Merging and keeping only the sublists whose first two elements are equal

I have a list containing sublists.

list= {{-9, 3, 2}, {-9, 3, 8}, {-9, 4, 3}, {-9, 4, 4}, {-7, 2, 2}, {-7, 2,
10}, {-7, 3, 4}, {-5, 1, 16}, {-5, 2, 4}, {-3, 1, 4}, {-3, 1,
6}, {3, 1, -14}, {3, 2, -8}, {3, 3, -6}, {3, 4, -5}, {3, 6, -4}, {7,
5, -8}, {9, 10, -6}}.


I want to keep sublists whose first two elements match.

{-9, 3, 2}, {-9, 3, 8}, {-9, 4, 3}, {-9, 4, 4}, {-7, 2, 2}, {-7, 2, 10}, {-3, 1, 4}, {-3, 1, 6} and merge these sublists into:

{{-9, 3, 2, 8}, {-9, 4, 3, 4}, {-7, 2, 2, 10}, {-3, 1, 4, 6}}

I would like to discard other sublists.

{-7, 3, 4}, {-5, 1, 16}, {-5, 2, 4},{3, 1, -14}, {3, 2, -8}, {3, 3, -6}, {3, 4, -5}, {3, 6, -4}, {7,5, -8}, {9, 10, -6}.

I tried by my hand to get {{-9, 3, 2, 8}, {-9, 4, 3, 4}, {-7, 2, 2, 10}, {-3, 1, 4, 6}}.

How can I tell Mathematica to do it?

KeyValueMap[Join]@
Select[Merge[GatherBy[Most@# -> Last@# & /@ list, First], Union],
Length@# == 2 &]


{{-9, 3, 2, 8}, {-9, 4, 3, 4}, {-7, 2, 2, 10}, {-3, 1, 4, 6}}.

KeyValueMap[Join] @
Select[Length @ # > 1 &] @
GroupBy[list, Most -> Last]

 {{-9, 3, 2, 8}, {-9, 4, 3, 4}, {-7, 2, 2, 10}, {-3, 1, 4, 6}}

\$Version

(* "13.3.1 for Mac OS X ARM (64-bit) (July 24, 2023)" *)

Clear["Global*"]

list = {{-9, 3, 2}, {-9, 3, 8}, {-9, 4, 3}, {-9, 4, 4},
{-7, 2, 2}, {-7, 2, 10}, {-7, 3, 4}, {-5, 1, 16},
{-5, 2, 4}, {-3, 1, 4}, {-3, 1, 6}, {3, 1, -14},
{3, 2, -8}, {3, 3, -6}, {3, 4, -5}, {3, 6, -4},
{7, 5, -8}, {9, 10, -6}};

list2 = Flatten[{Most[#[[1]]], #[[All, -1]]}] & /@
DeleteCases[GatherBy[list, Most], _?(Length[#] == 1 &)]

(* {{-9, 3, 2, 8}, {-9, 4, 3, 4}, {-7, 2, 2, 10}, {-3, 1, 4, 6}} *)

Clear["Global*"];
list = {{-9, 3, 2}, {-9, 3, 8}, {-9, 4, 3}, {-9, 4, 4}, {-7, 2,
2}, {-7, 2, 10}, {-7, 3, 4}, {-5, 1, 16}, {-5, 2, 4}, {-3, 1,
4}, {-3, 1, 6}, {3, 1, -14}, {3, 2, -8}, {3, 3, -6}, {3,
4, -5}, {3, 6, -4}, {7, 5, -8}, {9, 10, -6}};

GroupBy[list, #[[1 ;; 2]] &] // Select[Length@# > 1 &] //
KeyValueMap[Catenate@{#1, Flatten@#2[[All, 3 ;;]]} &]


Another journey:

First find duplicated keys.

k = CountsBy[list, #[[1 ;; 2]] &] // Select[# > 1 &] // Keys


{{-9, 3}, {-9, 4}, {-7, 2}, {-3, 1}}

list //
Map[Apply[Rule]]@*Map[TakeDrop[#, 2] &] //
Merge[#, Catenate] & //
KeySelect[#, MemberQ[k, #] &] & //
KeyValueMap[Join]


{{-9, 3, 2, 8}, {-9, 4, 3, 4}, {-7, 2, 2, 10}, {-3, 1, 4, 6}}

fun[{a_, b_} -> {c_, d_}] := {a, b, c, d}
fun[_] := Nothing

fun /@ Normal @ Merge[# &] @ Cases[{a__, b_} :> {a} -> b] @ list


{{-9, 3, 2, 8}, {-9, 4, 3, 4}, {-7, 2, 2, 10}, {-3, 1, 4, 6}}

Kludgy, but it works without removing duplicates from the resulting lists

list = {{-9, 3, 2}, {-9, 3, 8}, {-9, 4, 3}, {-9, 4, 4}, {-7, 2,
2}, {-7, 2, 10}, {-7, 3, 4}, {-5, 1, 16}, {-5, 2, 4}, {-3, 1,
4}, {-3, 1, 6}, {3, 1, -14}, {3, 2, -8}, {3, 3, -6}, {3,
4, -5}, {3, 6, -4}, {7, 5, -8}, {9, 10, -6}};


Count replicates by the first two elements of each sublist:

t1 = Tally[list[[All, {1, 2}]]]
(* {{{-9, 3}, 2}, {{-9, 4}, 2}, {{-7, 2}, 2}, {{-7, 3}, 1}, {{-5, 1},
1}, {{-5, 2}, 1}, {{-3, 1}, 2}, {{3, 1}, 1}, {{3, 2}, 1}, {{3, 3},
1}, {{3, 4}, 1}, {{3, 6}, 1}, {{7, 5}, 1}, {{9, 10}, 1}} *)



Keep the ones that have two replicates:

t2 = Cases[t1, {x___, 2} -> x]
(* {{-9, 3}, {-9, 4}, {-7, 2}, {-3, 1}} *)


Get the matching elements from the original list:

t3 = Cases[list, {# /. List -> Sequence, _}] & /@ t2
(* {{{-9, 3, 2}, {-9, 3, 8}}, {{-9, 4, 3}, {-9, 4, 4}}, {{-7, 2, 2}, {-7,
2, 10}}, {{-3, 1, 4}, {-3, 1, 6}}} *)


Combine the matching elements:

t4 = Join[#[[1, {1, 2}]], #[[All, 3]]] & /@ t3


{{-9, 3, 2, 8}, {-9, 4, 3, 4}, {-7, 2, 2, 10}, {-3, 1, 4, 6}}

Another way using Select and Subsets:

Join @@ # & /@ Map[DeleteDuplicates, Transpose /@ Select[Subsets[list, {2}],
Most@#[[1]] == Most@#[[2]] &], {2}]

(*{{-9, 3, 2, 8}, {-9, 4, 3, 4}, {-7, 2, 2, 10}, {-3, 1, 4, 6}}*)

la =
{{-9, 3, 2}, {-9, 3, 8}, {-9, 4, 3}, {-9, 4, 4}, {-7, 2, 2},
{-7, 2, 10}, {-7, 3, 4}, {-5, 1, 16}, {-5, 2, 4}, {-3, 1, 4},
{-3, 1, 6}, {3, 1, -14}, {3, 2, -8}, {3, 3, -6}, {3, 4, -5},
{3, 6, -4}, {7, 5, -8}, {9, 10, -6}};


Using SequenceCases

SequenceCases[la, {{a_, b_, c_}, {a_, b_, d_}} :> {a, b, c, d}]


{{-9, 3, 2, 8}, {-9, 4, 3, 4}, {-7, 2, 2, 10}, {-3, 1, 4, 6}}

If the list is unsorted:

lb = {{4, 2, 2}, {5, 1, 6}, {4, 2, 3}};

SequenceCases[Sort @ lb, {{a_, b_, c_}, {a_, b_, d_}} :> {a, b, c, d}]


{{4, 2, 2, 3}}

Using SplitBy and Select:

f1 = Map[First]@Most@#~Join~Last@# &@Thread@# &;

f2 = Select[SplitBy[Sort@#, Most@# &], Length@# > 1 &] &;

f1 /@ f2@list


{{-9, 3, 2, 8}, {-9, 4, 3, 4}, {-7, 2, 2, 10}, {-3, 1, 4, 6}}