# Combine sublists of nested list when the first two list elements are equal

New to Mathematica, I have a nested list with the following structure:

{ {A,B,C,D,E,F},{a,b,c,d,e,f},{G,H,I,J,K,L},.......}


All sublists are of equal length. I want to combine these sublists such that when A=a and B=b, the third list element C is replaced with the mean of C and c, element D is replaced with the mean of D and d, and so on through the last element of the sublists. The completed list would have the following form:

{{A,B,Mean[C,c],Mean[D,d],Mean[E,e],Mean[F,f]},....}


Thanks.

• When two sublists match their first 2 elements, they're replaced 1 sublist with mean values, but what's the result when the first 2 elements of the sublists elements don't match, that is, A ≠ a or B ≠ b? Maybe the sublists are removed from the nested list? Sep 19, 2021 at 21:05
• Hi @creidhne when the two sublists don't match, I just want to leave the sublists as they are i.e. {{A,B,C,D,E,F},{G,H,I,J,K,L}}  Sep 20, 2021 at 17:00

## 4 Answers

Welcome to MMA and MMA SE! There are many ways to do this. Here's a "straightforward" way, where it's easy to keep track of what happens when. The procedure we'll follow is

1. Group all lists which start with the same two elements into lists of those lists.

2. Act on each group of lists to combine them in the way you want.

For the first we'll use GatherBy with the function Take[#, 2] &. Take[list, 2] will produce a list consisting of the first 2 elements, and GatherBy will compare these values and put lists with the same value in the same list. See Rearranging And Restructuring Lists for more such functions. (Equivalent to Take[#, 2] &: #[[1;;2]] &, Extract[{{1},{2}}], and more.)

If you haven't seen it, <expression involving #> & is syntax for an anonymous function with argument slot #. There's another equivalent syntax for anonymous functions, which is x |-> <expression involving x>.

GatherBy[list, Take[#, 2] &]

(* Example: *)

a = {{3, 1, 0, 0, 0}, {3, 1, 1, 2, 2}, {3, 3, 1, 1, 1}, {0, 1, 1, 0, 2},
{1, 2, 0, 2, 3}, {3, 1, 2, 1, 0}, {3, 2, 2, 2, 3}, {0, 0, 2, 0, 1},
{2, 2, 0, 0, 2}, {3, 2, 1, 2, 2}}

GatherBy[a, Take[#, 2] &]

(* Out:

{{{3, 1, 0, 0, 0}, {3, 1, 1, 2, 2}, {3, 1, 2, 1, 0}}, {{3, 3, 1, 1, 1}},
{{0, 1, 1, 0, 2}}, {{1, 2, 0, 2, 3}}, {{3, 2, 2, 2, 3}, {3, 2, 1, 2, 2}},
{{0, 0, 2, 0, 1}}, {{2, 2, 0, 0, 2}}}

*)


Here we can use the fact that Mean[{a, a, a}] is a, and apply Mean "across" the whole group of lists: we want to turn a group of the form {{a1, a2, a3, ...}, {b1, b2, b3, ...}, ...} into {Mean[{a1, b1, ...}], Mean[{a2, b2, ...}], ...}.

So we want to Map (/@) a function that does this to a single group over the result of GatherBy, so as to apply it to each group. The function we want to map is one that first takes the Transpose (which is possible since all lists in a group will be the same length) and then applies Mean to all the lists that are elements of the resulting list. Applying Mean to all the elements is another Map. So we want to apply the following function to each group:

x |-> Mean /@ Transpose[x]


This is the function we want to Map over the result of GatherBy.

Putting it all together, let's define a function which will do this for an arbitrary list (of equal-length lists)

combineLists[list_] := (x |-> Mean /@ Transpose[x]) /@ GatherBy[list, Take[#, 2] &]

combineLists[a]

(* Out:

{{3, 1, 1, 1, 2/3}, {3, 3, 1, 1, 1}, {0, 1, 1, 0, 2}, {1, 2, 0, 2, 3},
{3, 2, 3/2, 2, 5/2}, {0, 0, 2, 0, 1}, {2, 2, 0, 0, 2}}


For familiarity with Mathematica: "threading across lists" like we do with Mean is actually a very common operation—so common that there's a built-in called MapThread to do something similar. For a function f, MapThread[f, {{a1, a2, a3, ...}, {b1, b2, b3, ...}, ...}] produces {f[a1, b1, ...], f[a2, b2, ...], ...}. Note that Mean, however, takes in a single list as an argument, not several different arguments. So instead of f[a1, b1, ...] we want Mean[{a1, b1, ...}]. There are two ways of still using MapThread, though!

1: When defining anonymous functions, # stands for the first argument. #2, #3, etc. stand for the next argument. (#1 is valid too, and is equivalent to #.) But what if we want to include the whole sequence of arguments, no matter how long it is? Then we use ##, and that stands for a whole Sequence. So here we can actually just use MapThread[Mean[{##}] &, group]. Also, MapThread has what's called an "operator form" which is common in Mathematica: MapThread[f] is a function that can be applied to a list, so MapThread[f][list] is the same as MapThread[f, list]. So we can just map MapThread[Mean[{##}] &]:

(* Equivalent definition *)

combineLists[list_] := MapThread[Mean[{##}] &] /@ GatherBy[list, Take[#, 2] &]


2: When we write {a,b,c} we're using syntactic sugar—it's not what's "really going on". The actual expression can be seen with FullForm, which is an incredibly useful tool in Mathematica, as it lets you see all the information you need. {a,b,c} is actually List[a, b, c]. List may as well be a function; in general, that part of the expression is called a head. (Head[{a,b,c}] gives List.) Note that, as in actual math, the function f[g[x, y, ...]] is the composition of f and g. So too in Mathematica; composition is denoted by @*. And what is Mean[{a,b,...}] but Mean[List[a,b,...]]? So we can instead simply use MapThread[Mean @* List] in our definition:

(* Equivalent definition *)

combineLists[list_] := MapThread[Mean @* List] /@ GatherBy[list, Take[#, 2] &]


Finally, as pointed out by @kglr, we can simply use Mean[group] instead of e.g. Mean /@ Transpose[group]! This is because Mean averages the elements of the group as vectors, and averaging on vectors works componentwise! As another note on how Mathematica handles operations on lists, some symbols like Plus have the attribute Listable. (Evaluate Attributes[Plus] to see Listable along with a whole lot of others. In general, attributes affect the way a function is both evaluated and pattern-matched in special, built-in ways.) This means that the Plus operation is threaded over any lists appearing in its argument: 1 + {a,b,c} is {1 + a, 1+ b, 1+ c}, {a,b,c} + {x,y,z} is {a x, b y, c z}, etc. ("Threading" can be done manually—and over different heads than List!—with the function Thread.) All basic numeric functions are Listable, such as Times, Power, etc. (You can make your own function Listable with e.g. SetAttributes[f, Listable].) In any case, I hope the explanation using Transpose and MapThread was still informative! :)

• Mean[{{a,b,c},{x,y,z},{u,v,w}}] gives the same result as Mean/@Transpose[{{a,b,c},{x,y,z}, {u,v,w}}]. So we can use Mean/@GatherBy[list, Take[#, 2] &] (no need for MapThread or Transpose).
– kglr
Sep 20, 2021 at 14:27
• Thank you for the detailed response! This resolved everything perfectly. Sep 20, 2021 at 17:05

A 10X5 matrix as an example input:

SeedRandom[1];
lists = RandomInteger[3, {10, 5}];

MatrixForm @ lists


You can use GroupBy + Mean + Values as follows:

Values @ GroupBy[lists, #[[{1, 2}]] &, Mean]

{{3, 1, 0, 1, 1}, {0, 0, 1/3, 4/3, 5/3}, {0, 1, 5/2, 3/2, 0},
{3, 3, 5/2, 2, 3/2}, {2, 0, 1, 1, 3}, {1, 0, 1, 0, 3}}

MatrixForm @ %


We can generalize this into a function that takes a list of lists, a list of column indices to group by, and a function (that returns a list with length equal to number of columns in the input matrix) to apply to groups. The third argument is optional with default value Mean.

ClearAll[f1]
f1[lst_, parts_, func_ : Mean] := KeyValueMap[ReplacePart[#2, Thread[parts -> #]] &]@
GroupBy[lst, #[[parts]] &,  func]


Examples:

cols = {1, 2};
Row[Pane[MatrixForm @ #, BaselinePosition -> Top] & /@
{lists, MatrixForm[Values@GroupBy[lists, #[[cols]] &, MatrixForm]],
f1[lists, cols]}, Spacer[10]]


With cols = {2, 5} we get

Highlight keys and groups:

ClearAll[highlightByKeys]
highlightByKeys[keys_] := Module[
{styl = AssociationThread[#, ColorData[97] /@ Range[Length@#]] & @
DeleteDuplicates[#[[All, keys]]]},
Map[(x |-> Map[Highlighted[#, Background -> styl[x[[keys]]]] &,
MapAt[Style[#, 18, Bold] &, x, List /@ keys]])] @ #] &


Examples:

Row[Pane[Labeled[MatrixForm@#, #2, Top],
BaselinePosition -> Top] & @@@
{{highlightByKeys[cols]@lists, "lists"},
{highlightByKeys[cols]@f1[lists, cols], "mean"},
{highlightByKeys[cols]@f1[lists, cols, Total], "total"},
{highlightByKeys[cols]@f1[lists, cols, Max /@ Transpose[#] &], "max"},
{highlightByKeys[cols]@f1[lists, cols, First], "first"}},
Spacer[10]]


With cols = {2, 5} we get

With cols = {3} we get

With cols = {1, 4, 5} we get

Starting from the same point as @creidhne:

t = Partition[pairedList, 2]

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


Write a function to check the equality of the first two entries (discarding the pair when necessary), and find the mean of the pair of lists (element-wise). Join sections as needed.

f[{m_List, n_List}] := Module[{},
If[m[[1]] != n[[1]], Return[Nothing]];
If[m[[2]] != n[[2]], Return[Nothing]];
Join[m[[1 ;; 2]], Mean /@ Transpose[{m, n}][[3 ;; -1]]]
]

Map[f, t, 1] (* f /@ t *)

{{7, 4, 8, 17/2, 9/2, 5}, {2, 0, 6, 2, 13/2, 6}, {4, 10, 13/2, 5, 3,
6}}


Assume that sublists are paired, and that the result should have no sublist when two paired sublists don't match their first 2 elements. The reasoning for removing unmatched sublist pairs is that they'd be indistinguishable from pairs that match.

Make a sample list and set the second pair of sublists so that the first 2 elements don't match.

SeedRandom[123];
n = 4;
pairedList = Flatten[Table[{Join[#, RandomInteger[10, n]],
Join[#, RandomInteger[10, n]]}&@RandomInteger[10, 2],{4}], 1];
pairedList[[3, 1]] = 1;
TableForm[Partition[pairedList, 2], TableDepth -> 2]


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

Check each pair of sublists. If the first 2 elements match, replace them with a list with means, otherwise remove the two sublists from the output. With the sample nested list, we removed the second two sublists, and there are three lists with means in the result.

Table[If[
Take[pairs[[1]], 2] == Take[pairs[[2]], 2],
Join[Take[#1, 2], N@Mean[{Drop[#1, 2], Drop[#2, 2]}]] &@@ pairs,
Nothing],
{pairs, Partition[pairedList, 2]}]


{{7, 4, 8., 8.5, 4.5, 5.}, {2, 0, 6., 2., 6.5, 6.}, {4, 10, 6.5, 5., 3., 6.}}

## Edit reply to comment:

To keep sublists that don't match, we can use:

Flatten[
Table[If[
Take[pairs[[1]], 2] == Take[pairs[[2]], 2],
{Join[Take[#1, 2], N@Mean[{Drop[#1, 2], Drop[#2, 2]}]] &@@ pairs},
Join[pairs]],
{pairs, Partition[pairedList, 2]}], 1]


{{7, 4, 8., 8.5, 4.5, 5.}, {1, 9, 8, 10, 5, 2}, {3, 9, 10, 6, 2, 6}, {2, 0, 6., 2., 6.5, 6.}, {4, 10, 6.5, 5., 3., 6.}}