Multidimensional interpolation with duplicate abscissa values

Question

I am trying to do a first order interpolation on a multidimensional data set containing duplicate abscissa values (which Mathematica does not like), like this one:

{{{1, 2, 3}, 10}, {{1, 2, 3}, 20}, {{1, 2, 4}, 30}}

After playing around with DeleteDuplicates and Union I found that DeleteDuplicates does not work on multidimensional data, at least not when represented like above. I found that Union could delete the duplicates by using the SameTest-option, like this:

Union[{{{1, 2, 3}, 10}, {{1, 2, 3}, 20}, {{1, 2, 4}, 30}}, SameTest -> (#1[[1]] == #2[[1]] &)]

which returns

{{{1, 2, 3}, 10}, {{1, 2, 4}, 30}}

However, it is very slow with larger data sets, which I have, so that is not an option.

What I really would like is a function that will make an average of the duplicates, so that

{{{1, 2, 3}, 10}, {{1, 2, 3}, 20}, {{1, 2, 4}, 30}}

will turn into

{{{1, 2, 3}, 15}, {{1, 2, 4}, 30}}

I am by no means an expert in Mathematica programming, so I could really use some help.

The solution has to be reasonable fast. My data set is not sorted in any way but I guess it can be sorted quickly before the duplicates are combined if that is needed.

Thanks in advance :-)

Answer 1

DeleteDuplicatesBy may be faster if used as follows:

DeleteDuplicatesBy[{{{1, 2, 3}, 10}, {{1, 2, 3}, 20}, {{1, 2, 4}, 30}}, First]

{{{1, 2, 3}, 10}, {{1, 2, 4}, 30}}

For your second need:

lis = GatherBy[{{{1, 2, 3}, 10}, {{1, 2, 3}, 20}, {{1, 2, 4}, 30}}, First];
mean = Mean /@ Map[Last, lis, {2}];

Then:

Transpose[{lis[[All, 1, 1]], mean}]

{{{1, 2, 3}, 15}, {{1, 2, 4}, 30}}

As a function:

delDupMean[data_] := With[{lis = GatherBy[data, First]},
  Transpose[{lis[[All, 1, 1]], Mean /@ Map[Last, lis, {2}]}]
 ]

Use:

delDupMean[{{{1, 2, 3}, 10}, {{1, 2, 3}, 20}, {{1, 2, 4}, 30}}]

{{{1, 2, 3}, 15}, {{1, 2, 4}, 30}}

Answer 2

lst = {{{1, 2, 3}, 10}, {{1, 2, 3}, 20}, {{1, 2, 4}, 30}};

DeleteDuplicates[lst, First@#1 == First@#2 &]
(* {{{1,2,3},10},{{1,2,4},30}} *)

First /@ GatherBy[lst, First]
(* {{{1,2,3},10},{{1,2,4},30}} *)

{#[[1, 1]], Mean[#[[All, 2]]]} & /@ GatherBy[lst, First]
(* or {#[[1, 1]], Mean[#[[All, 2]]]} & /@Gather[lst, First@#1 == First@#2 &]  *)
(* {{{1,2,3},15},{{1,2,4},30}} *)

Answer 3

Just an approach with Reap and Sow. Probably not be efficient.

data = {{{1, 2, 3}, 10}, {{1, 2, 3}, 20}, {{1, 2, 4}, 30}};
Last@Reap[Sow[#2, w[#1]] & @@@data, _, {ReplacePart[#1, 0 -> Identity], Mean@#2} &]

yields:

(*{{{1, 2, 3}, 15}, {{1, 2, 4}, 30}}*)

Answer 4

lis = GatherBy[{{{1, 2, 3}, 10}, {{1, 2, 3}, 20}, {{1, 2, 4}, 30}}, First];

Plus @@@ lis/Length /@ lis

Plus @@ #/Length@# & /@ lis

Plus[##]/Length@{##} & @@@ lis

(*{{{1, 2, 3}, 15}, {{1, 2, 4}, 30}}*)

Answer 5

list = {{{1, 2, 3}, 10}, {{1, 2, 3}, 20}, {{1, 2, 4}, 30}};

result = GroupBy[list, First -> Last, Mean]

Normal @ result /. Rule -> List

OR

Thread[{Keys @ #, Mean /@ Values @ #}] &[GroupBy[list, First -> Last]]