# Modify one list according to degeneracies of another

I have two lists, each with four elements, let's say

listA = {0.3, 0.6, 0.6, 0.9}
listB = {0.1, 0.2, 0.3, 0.4}


Notice that the second and third element of listA are the same. I would like to modify listB by summing the corresponding elements, such that in the end I get

listB = {0.1, 0.5, 0.5, 0.4}


where 0.5 = 0.2 + 0.3. In general I could have three or four degenerate members of listA, and I would like to have some cutoff for treating the floating point values of listA as being the same (e.g. $$10^{-15}$$). I could also have no degeneracy in listA, in which case listB should be unmodified. I haven't found a nice way to do this without resorting to loops and If statements.

• Since nobody asked: are the degenerate elements always adjacent to each other, or can they be separated by other elements? May 26 at 12:44
• @J.M. we can assume that listA is sorted from least to greatest, so they are always adjacent
– Kai
May 26 at 13:50

Here’s a simple way:

listA /. Merge[Thread[listA -> listB], Total]
{0.1, 0.5, 0.5, 0.4}

• This is very nice
– Kai
May 30 at 23:22

# TL;DR

listA = {0.3, 0.6, 0.6, 0.9}
listB = {0.1, 0.2, 0.3, 0.4}
threshold = 10^-15;

(*Revised and better way thanks to J.M.*)
f[list1_, list2_, Method -> "Unitize"] := (1 - Unitize[Chop[Outer[Plus, list1, -list1], threshold]]).list2

(*Old*)
f[list1_, list2_, Method -> "Boole"] := Outer[Boole[Chop[#1 - #2, threshold] == 0] &, list1, list1].list2

(*Run-Length Block Diagonal Matrix*)
f[list1_, list2_, Method -> "RLBDM"] := Block[
{runs, runLengthMatrixList},
runs = Split[list1, Abs[#1 - #2] < 10^-15 &];
runLengthMatrixList = ConstantArray[1, Length@# {1, 1}] & /@ runs;
(*see below*) matrixDirectSum[runLengthMatrixList].list2
]

(*SequencePosition*)
f[list1_, list2_, Method -> "SequencePosition"] := Block[
{temp = list2, pos = SplitBy[SequencePosition[list1, {x_, (x_) ..}], #[[2]] &][[;; , 1]]},
(temp[[Span @@ #]] = Total@Take[list2, #]) & /@ pos;
temp
]

f[listA, listB, Method -> #] & /@ {"Boole", "Unitize", "RLBDM", "SequencePosition"}


{{0.1, 0.5, 0.5, 0.4}, {0.1, 0.5, 0.5, 0.4}, {0.1, 0.5, 0.5, 0.4}, {0.1, 0.5, 0.5, 0.4}}

# The Long Part

WE CaN seE that $$\left( \begin{array}{cccc} 1 & 0 & 0 & 0 \\ 0 & 1 & 1 & 0 \\ 0 & 1 & 1 & 0 \\ 0 & 0 & 0 & 1 \\ \end{array} \right) \cdot \left( \begin{array}{c} w \\ x \\ y \\ z \\ \end{array} \right) = \left( \begin{array}{c} w \\ x + y \\ x + y \\ z \\ \end{array} \right)$$ where the block-, sub-matrix of 1s comes from the positions (or position and length of the run since they will always be adjacent) of the duplicate elements. Now it's just a matter of creating that matrix from the secondary vector.

## Outer Product

One way of going about making the transformation is using the outer product Outer to element-wise identify the entries that are within the threshold of each other.

f[list1_, list2_, Method -> "Boole"] := Outer[Boole[Chop[#1 - #2, 10^-15] == 0] &, list1, list1].list2
f[list1_, list2_, Method -> "Unitize"] :=  (*Thanks J.M.*) (1 - Unitize[Chop[Outer[Plus, list1, -list1], 10^-15]]).list2


## Matrix Direct Sum and Run-Length Block Diagonal Matrix

Another method is to take advantage of the fact that the duplicate elements will always be adjacent, thus creating runs of identical entries. The length of these runs (including runs of length 1) is exactly the dimension of the block matrix that appears on the diagonal of our transformation. Then we can compute the direct sum of these matrices (i.e. a block diagonal matrix whose diagonal entries are the run-matrices).

matrixDirectSum[matList : {__?MatrixQ}] := SparseArraySparseBlockMatrix[Transpose@Range[1, Length@matList {1, 1}] -> matList // Thread] // Normal

f[list1_, list2_, Method -> "RLBDM"] := Block[
{runs, runLengthMatrixList},
runs = Split[list1, Abs[#1 - #2] < 10^-15 &] (*Partition the list into runs of entries that are within the threshold*);
runLengthMatrixList = ConstantArray[1, Length@# {1, 1}] & /@ runs (*Create a list of square 1-matrices with dimension equal to the length of the run*);
matrixDirectSum[runLengthMatrixList].list2
]


SparseArraySparseBlockMatrix found via tumbling down the rabbit hole of this question to this question and finally to this question. I have also had this nagging feeling that the block matrix could be constructed more directly via Kronecker sums and/or Kronecker products.

## SequencePosition

In doing something else, using SequencePosition also popped into my head.

f[list1_, list2_, Method -> "SequencePosition"] := Block[
{temp = list2, pos = SplitBy[SequencePosition[list1, {x_, (x_) ..}], #[[2]] &][[;; , 1]]},
(temp[[Span @@ #]] = Total@Take[list2, #]) & /@ pos;
temp
]


This even works as below because it takes and adds the orthogonal rows of the identity matrix.

## Just the matrix

In any case, we can also implement the functionality to give just the matrix.

f[list_, m : (Method -> _)] := f[list, IdentityMatrix@Length@list, m]
f[listA, Method -> "RLBDM"]


$$\left( \begin{array}{cccc} 1 & 0 & 0 & 0 \\ 0 & 1 & 1 & 0 \\ 0 & 1 & 1 & 0 \\ 0 & 0 & 0 & 1 \\ \end{array} \right)$$

This is also the form of an adjacency matrix of the graph representation of the matrix.

## Timing Comparison

With[
{lists = Round[RandomReal[1, {2, #}], 0.1]},
First@RepeatedTiming[
f[## & @@ lists, Method -> #];] & /@ {"Boole", "Unitize", "RLBDM", "SequencePosition"}
] & /@ Range[100, 1000, 100] // Transpose
ListLogPlot[
%,
DataRange -> {100, 1000},
PlotLegends -> {"Boole", "Unitize", "RLBDM", "SequencePosition"},
Joined -> True, Axes -> False, Frame -> True,
FrameLabel -> {"List length", "Time [s]"}
] // Rasterize


Turns out the RLBDM method is at least an order of magnitude quicker than the others! And as expected, SequencePosition is slowest at higher lengths, no doubt due to pattern matching.

• I like this, very clever May 26 at 8:43
• I would modify this to (1 - Unitize[Chop[Outer[Plus, listA, -listA], 10^-15]]) . listB. May 26 at 14:09
• Chop[#1 - #2, 10^-15] == 0 means close enough. Boole[...] means bool to 0 and 1, Outer[xx, listA, listA] means for each element, compare itself with other elements. So get a 0-1 matrix, each means one element has any position same with others. . to apply to listB. May 26 at 14:09
• @J.M. There's the Unitize I was originally trying to use. For some reason my mind couldn't think of a way to make 0 -> 1 && 1 -> 0. Yay arithmetic! May 28 at 0:54
• (+1) A great answer. I learned a lot. But do the values within a given tolerance in alist have to be adjacent? alistX={2.2, 0.6, 0.3, 0.6, 0.9} blistX={4.4,0.2,0.1, 0.3,0.4} and Outer[Boole[Chop[#1 - #2, 10^(-4)] == 0] &, alistX, alistX].blistX gives (in my hands) {4.4, 0.5, 0.1, 0.5, 0.4}. But perhaps I am missing something very obvious? May 30 at 21:08

You could write:

listA = {0.3, 0.6, 0.6, 0.9};
listB = {0.1, 0.2, 0.3, 0.4};
Total[Map[listB[[#]] &, Nearest[listA -> "Index", listA, {∞, 10^-15}], {-1}], {2}]
(* {0.1, 0.5, 0.5, 0.4} *)


Or more simply:

Total[Nearest[listA -> listB, listA, {∞, 10^-15}], {2}]
(* {0.1, 0.5, 0.5, 0.4} *)


EDIT Better algorithm for detecting consecutive runs

(Thanks to @user1066 for detecting this shortcoming)

threshold = 10^-2;
alist = {0.3, 0.6, 0.6, 0.605, 0.9, 0.8, 0.095, 0.1, 0.1, 0.3};
blist = {0.1, 0.2, 0.3, 0.1, 0.4, 0.6, 0.5, 0.4, 0.1, 0.1};


It becomes cumbersome with Differences that I originally used, so I will use Split with a similar split function.

alistSplit =
Split[alist, Between[#1, {#2 - threshold, #2 + threshold}] &]


{{0.3}, {0.6, 0.6, 0.605}, {0.9}, {0.8}, {0.095, 0.1, 0.1}, {0.3}}

degenPos =
Flatten[Length /@ alistSplit /. {1 -> 0,
x_Integer :> ConstantArray[1, x]}]


{0, 1, 1, 1, 0, 0, 1, 1, 1, 0}

If blist were split, it would look like:

blistSplit = TakeList[blist, Length /@ alistSplit]


{{0.1}, {0.2, 0.3, 0.1}, {0.4}, {0.6}, {0.5, 0.4, 0.1}, {0.1}}

and the individual totals would be:

Total@## & /@ blistSplit


{0.1, 0.6, 0.4, 0.6, 1., 0.1}

Putting it together:

clist = Flatten@
ConstantArray[#1, #2] &, {Total@## & /@ blistSplit,
Length /@ alistSplit}]


For visualization:

arrows = degenPos /. {0 -> "\[Cross]",
1 -> Style["\[UpDownArrow]", Bold, Red]}

Grid@{alist, arrows, blist, arrows,
MapAt[Framed[#, Background -> Yellow] &, clist,
Position[degenPos, 1]]}


Original attempt (not working properly for consecutive runs)

threshold = 10^-4;
SeedRandom[9];
alist = RandomInteger[{1, 10}, 15]/10.0 + RandomReal[{-0.01, 0.01}];
blist = RandomInteger[{1, 10}, 15]/10.0 + RandomReal[{-0.01, 0.01}];

degenPos = ({#, # + 1} & /@ Flatten[#, 1] &@
Position[Differences[alist],
x_ /; Between[x, {-threshold, +threshold}]])


{{5, 6}, {13, 14}}

tots = Total@blist[[#]] & /@ degenPos


{1.41283, 1.31283}

For visualization:

arrows = ReplacePart[
ConstantArray["\[Cross]",
Length@alist], # -> Style["\[UpDownArrow]", Bold, Red] & /@
Flatten@degenPos]

clist = ReplacePart[blist,
Rule @@@ Transpose[{degenPos, tots}])]

Grid@{alist, arrows, blist, arrows,
MapAt[Framed[#, Background -> Yellow] &, clist,
List /@ Flatten@degenPos]}


• Thanks @user1066 for pointing it out. I should have been more diligent. I have updated the answer.
– Syed
May 31 at 1:47

My attempt for your problem is as follows:

ReplaceByDegeneracy[listA_, listB_] := Block[{dupA, posA, extractB, arrayB},
dupA = Mean[Flatten[Map[If[#[[1]] === #[[2]], #, Nothing] &,
DeleteDuplicates[Subsets[listA, {2}]]]]];
posA = Position[listA, dupA];
extractB = Extract[listB, posA];
arrayB = Array[Total[Extract[listB, posA]] &, Length[extractB]];


Test:

ReplaceByDegeneracy[listA, listB]
(*{0.1, 0.5, 0.5, 0.4}*)


Also:

listC = {0.3,0.6,0.6,0,6};
ReplaceByDegeneracy[listC, listB]
(*{0.1, 0.9, 0.9, 0.9}*)


s=Length/@Split[listA,Abs[#1-#2]<10^(-5)&];