data = {{0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 1, 1, 1, 0, 1, 1},
{1, 1, 1, 0, 1, 0, 0, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 0, 0, 0}}
ReplaceRepeated[data, {x___,
z : Longest[Repeated[1, {2, Infinity}]],
y___} :> {x, Sequence @@ ConstantArray[0, Length@{z}], y}]
(*
{{0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0},
{0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}
*)
Or shorthand:
data //. {x___, z : Longest[Repeated[1, {2, Infinity}]], y___} :>
{x, Sequence @@ ConstantArray[0, Length@{z}], y}
Per our comment conversation, a sketch of an idea to speed things for large arrays:
sa = SparseArray[data]["AdjacencyLists"];
diff = Differences /@ sa;
map = MapThread[Pick[#1, Append[#2, 0], 1] &, {sa, diff}];
split = Split[#, #1 == #2 - 1 &] & /@ map;
MapIndexed[If[#1 != {}, data[[First@#2, Append[#1, Last@#1 + 1]]] = 0] &, split, {2}];
Result in original data
array. This is hugely faster on large arrays, but there's undoubtedly room to improve.
Update:
Here's where the structure of your data can be used to our advantage. By moving to the string domain to do the replacement work and then converting back to the binary, we can over triple the speed of the SparseArray
technique:
result = With[{zz = FromCharacterCode[0],
zo = FromCharacterCode[1],
zt = FromCharacterCode[2], lst = #},
ToCharacterCode[
StringReplace[
FixedPoint[
StringReplace[#, {StartOfString ~~ zo ~~ zz -> zt <> zz,
zz ~~ zo ~~ zz -> zz <> zt <> zz,
zz ~~ zo ~~ EndOfString -> zz <> zt}] &,
FromCharacterCode[lst]], {zo -> zz, zt -> zo}]]] &[data];
Update 2:
As happens sometimes (particularly when one has been working on a similar problem and thinks "hmmmm, this seems the same..."), I way over-thought this.
Flatten /@
Replace[Split /@ #, z:{Repeated[1, {2, Infinity}]} :> ConstantArray[0, Length@z],
{2}] &[data]
Is much faster. As with other solutions above using Repeated
, replace the 2
with the desired minimum number of ones to replace. Also, for small minimums, direct pattern matching will be slightly faster, e.g.:
Flatten /@
Replace[Split /@ #, z : {1, 1 ..} :> ConstantArray[0, Length@z], {2}] &[data]
Flatten /@
Replace[Split /@ #, z : {1,1, 1 ..} :> ConstantArray[0, Length@z], {2}] &[data]
Will replace for minimums of 2 and 3 ones in sequence, respectively. Also, depending on packed status, using Join@@@
in place of Flatten/@
might speed things up a bit on large arrays.
For the specific case of replacing repeated ones of length 2 or more, the following is very fast (up to 10X the fastest above) when the sublists are long (as in say a 100x100000 array):
With[{ap = ArrayPad[#, {1, 1}]},
Clip[ArrayPad[ap - RotateLeft[ap] - RotateRight[ap], {-1, -1}],
{1,1}, {0, 0}]] & /@ data
I note you've changed the OP data - note you'll need to adjust some of the methods here to account for that (e.g., FromCharacterCode
will not work with non-integer values, so conversion to that would be needed, and the patterns need to use 1.
vs 1
).