Substitute some 1s with 0s in random list

Question

How is it better to substitute list of random combination of 1 and 0 (binary image) so that only first (or central) instance of 1 left in each group.

list = {0,1,1,0,0,1,0,1,1,1,0} should be {0,1,0,0,0,1,0,1,0,0,0}

There should be a kind of Erosion but keeping 1s. I'm thinking about replacement rule.

Answer 1

Updated to include suggestions from comments

My original idea, using BitAnd, switching $0\leftrightarrow1$, and multiplying. This idea uses 3 vectorized binary operations:

erode1[list_] := Times[
    list,
    Subtract[
        1,
        BitAnd[list, PadRight[list, Length@list, 0, 1]]
    ]
]

Here is @Shadowray's improvement, which uses 2 vectorized binary operations. In addition, ArrayPad is slightly faster than PadRight:

erode2[list_] := Times[
    list,
    BitXor[list, ArrayPad[list, {1, -1}]]
]

Finally, here is an approach inspired by @garej and @LouisB, which uses 1 vectorized binary operation and 1 vectorized unary operation:

erode3[list_] := Ramp @ Subtract[
    list,
    ArrayPad[list, {1, -1}]
]

Here is a comparison of there timings:

data = RandomInteger[1, 10^7];

r1 = erode1[data]; //RepeatedTiming
r2 = erode2[data]; //RepeatedTiming
r3 = erode3[data]; //RepeatedTiming

r1 === r2 === r3

{0.101, Null}

{0.082, Null}

{0.078, Null}

True

vectorized unary vs binary operators

@io_tuta ask about vectorized unary vs binary operators. This answer (3496) provides a very nice description of vectorized (i.e. packed array) operations. As for the particular difference between unary and binary operators, I expect that unary operators ought to be faster than binary operators. Here is an example demonstrating this:

d1 = RandomReal[1, 10^7];
d2 = RandomReal[1, 10^7];

d1+d2; //RepeatedTiming
UnitStep[d1]; //RepeatedTiming

{0.024, Null}

{0.019, Null}

The unary UnitStep operation is significantly faster than the binary Plus operation

Answer 2

The following function is based on the Ramp and Differences functions, as suggested in a comment by @garej . Its speed and low memory are surprising.

rampDiff[list_] := Ramp@Prepend[Differences[list], First[list]]

It was tested against the following functions from previous answers and comments:

ClearAll["Global`*"]

erode1[list_] := 
 Times[list, 
  Subtract[1, BitAnd[list, PadRight[list, Length@list, 0, 1]]]]

erode2[list_] := BitXor[ArrayPad[list, {1, -1}], list]*list

fcn = Function[{list}, 
   Replace[Split[list], 
     l : {1, __} :> {1, ConstantArray[0, Length@l - 1]}, 1] // 
    Flatten];

bruteForce[list_] := 
  Join[{list[[1]]}, 
   Table[If[list[[i - 1]] == list[[i]] == 1, 0, list[[i]]], {i, 2, 
     Length[list]}]];

rep[a_] := a
rep[{1, a___}] := {1, {a} - 1}
repSplit[list_] := rep /@ Split@list // Flatten

shortest[list_] := (list //. {a___, 1, 1, Shortest[b___]} :> {a, 1, 0,
      b})

caseDiff[list_] := 
 Cases[Prepend[Differences[list], First[list]], x_ :> Boole[x == 1]]

The first test was to see that all of the functions give the same results.

functions = { shortest, bruteForce,  repSplit, fcn, caseDiff, erode2, 
   erode1, rampDiff};
data = RandomChoice[{0, 1}, 10^4];

results = Through[functions[data]];
1 == Length@Union@results

(*   True   *)

The execution time and memory usage tests were conducted as follows.

Through[(Composition[AbsoluteTiming, MaxMemoryUsed, #] & /@ 
     functions)[data]];
μsecs = Round[Transpose[{1000000, 1} Transpose[%]], 1];
Grid[Prepend[μsecs, {"μ-secs", "Bytes"}], 
 Alignment -> {Right, Baseline}]

   (* μ-secs      Bytes
      600599     321656
        7894     169720
        6166     813704
        4284     848216
        5789    1291216
        2737     720384
         344     320856
         230     160408   *)

In this test the rampDiff function edged out erode1 in speed and bruteForce in low memory usage. Thanks to @garej for suggesting it.

Answer 3

First Split the list into runs of zeros and ones:

split = Split[list]

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

Then process the lists of ones with length greater than one. One method is with a replacement rule, though a functional approach might be a bit faster:

Replace[split, l : {1, ___} :> {1, ConstantArray[0, Length@l - 1]}, 1]

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

and finally Flatten to get the desired output:

Flatten @ %

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

---

Putting it all together:

fcn = Function[{list},
 Replace[Split[list],
   l : {1, __} :> {1, ConstantArray[0, Length@l - 1]},
   1]
  // Flatten
 ]

fcn @ list

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

---

Note: We could have used Sequence@@ConstantArray[...] in the second step, but I didn't bother since we were planning to flatten the list anyway.

Answer 4

rep[a_] := a
rep[{1, a___}] := {1, {a} - 1}

rep /@ Split@list // Flatten

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

Answer 5

Here's an approach using Table that is mid-way in terms of speed:

bruteForce[list_] := Join[{list[[1]]}, Table[If[list[[i - 1]] == list[[i]] == 1, 0, list[[i]]], {i, 2, 
     Length[list]}]];


data = RandomInteger[1, 10^6];
r1 = erode[data]; // MaxMemoryUsed // AbsoluteTiming
r2 = fcn[data]; // MaxMemoryUsed // AbsoluteTiming
r3 = bruteForce[data]; // MaxMemoryUsed // AbsoluteTiming

r1 === r2
r1 === r3

{0.0101832, 16000656}

{0.395556, 84964056}

{0.0529076, 16000760}

True

True