10
$\begingroup$

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.

Improve this question
$\endgroup$
2
  • 1
    $\begingroup$ Since nobody asked: are the degenerate elements always adjacent to each other, or can they be separated by other elements? $\endgroup$
    – J. M.'s missing motivation ♦
    May 26, 2022 at 12:44
  • $\begingroup$ @J.M. we can assume that listA is sorted from least to greatest, so they are always adjacent $\endgroup$
    – Kai
    May 26, 2022 at 13:50

7 Answers 7

Reset to default
12
$\begingroup$

Here’s a simple way:

listA /. Merge[Thread[listA -> listB], Total]
{0.1`, 0.5`, 0.5`, 0.4`}
Improve this answer
$\endgroup$
1
  • $\begingroup$ This is very nice $\endgroup$
    – Kai
    May 30, 2022 at 23:22
9
$\begingroup$

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}] := SparseArray`SparseBlockMatrix[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
]

SparseArray`SparseBlockMatrix 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.

enter image description here

Improve this answer
$\endgroup$
7
  • 1
    $\begingroup$ I like this, very clever $\endgroup$
    – Daniel Huber
    May 26, 2022 at 8:43
  • 3
    $\begingroup$ I would modify this to (1 - Unitize[Chop[Outer[Plus, listA, -listA], 10^-15]]) . listB. $\endgroup$
    – J. M.'s missing motivation ♦
    May 26, 2022 at 14:09
  • $\begingroup$ 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. $\endgroup$
    – AsukaMinato
    May 26, 2022 at 14:09
  • $\begingroup$ @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! $\endgroup$
    – NonDairyNeutrino
    May 28, 2022 at 0:54
  • $\begingroup$ (+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? $\endgroup$
    – user1066
    May 30, 2022 at 21:08
4
$\begingroup$

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]];
ReplaceAll[Thread[extractB -> arrayB]][listB]]

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}*)
Improve this answer
$\endgroup$
4
$\begingroup$

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} *)
Improve this answer
$\endgroup$
4
$\begingroup$

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@
  MapThread[
   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]]}

enter image description here

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, 
  Flatten[#, 1] &@(Thread[#] & /@ 
     Rule @@@ Transpose[{degenPos, tots}])]

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

enter image description here

Improve this answer
$\endgroup$
1
  • $\begingroup$ Thanks @user1066 for pointing it out. I should have been more diligent. I have updated the answer. $\endgroup$
    – Syed
    May 31, 2022 at 1:47
1
$\begingroup$

I'll just add my personal solution in addition to the other excellent answers.

s=Length/@Split[listA,Abs[#1-#2]<10^(-5)&];
listB=Flatten@Table[ConstantArray[Total@i,Length@i],{i,TakeList[listB,s]}];
Improve this answer
$\endgroup$
1
$\begingroup$ 
a = {0.3, 0.6, 0.6, 0.9};

b = {0.1, 0.2, 0.3, 0.4};

CLS = Internal`CopyListStructure;

Using Replace, CopyListStructure and SequenceCases

Replace[
 CLS[SequenceCases[a, {x_ ...}], b],
 x : {__} :> Splice @ Table[Total @ x, Length @ x],
 {1}]

{0.1, 0.5, 0.5, 0.4}

A more complicated case

a = {0.3, 0.6, 0.6, 0.6, 0.9, 0.5, 0.5};

b = {0.1, 0.2, 0.3, 1.0, 0.4, 0.1, 1.0};

Replace[
 CLS[SequenceCases[a, {x_ ...}], b],
 x : {__} :> Splice@Table[Total@x, Length@x],
 {1}]

{0.1, 1.5, 1.5, 1.5, 0.4, 1.1, 1.1}

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.