Replacing Patterns In a List of Varying Length

Question

I am working with an array of data that may look something like this.

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.}}

I want to replace any sequence of ones that exceeds two in a row with the same number of zeros in order to maintain the original dimensions of the array. I came up with the following to try to do this.

data /. {x__, PatternSequence[Repeated[1., {2}]], y__} -> {x}~Join~Table[0., {i, 2}]~Join~{y}

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

Unfortunately, it only replaces the first two ones in a sequence with zeros and leaves the rest. That's not exactly what I was aiming for.

Answer 1

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).

Answer 2

Another way to use StringReplace:

rF = With[{dt = #, num = #2},  PadLeft[#, Dimensions[dt]] &@
   (IntegerDigits /@ ToExpression /@ 
       (StringReplace[#, z : Repeated["1", {num, Infinity}] :> 
         StringReplace[z, "1" -> "0"]] &[IntegerString /@ FromDigits /@ dt]))] &

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}};
rF[data,2]
(* {{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}} *)
rF[data,4]
(* {{0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 1, 1}, 
    {1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}*)

Comparison with @rasher's string-based method:

rasherF =  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}]]] &;


rndData = RandomChoice[{0, 1}, {100000, 100}];
resulta = rF[rndData, 2]; // Timing
(* {4.968750, Null} *)
resultb = rasherF[rndData]; // Timing
(* {3.671875, Null} *)
resulta = =resultb
(* True *)

rndData2 = RandomChoice[{0, 1}, {792001, 111}];
resulta2 = rF[rndData2, 2]; // Timing
(* {43.609375, Null} *)
resultb2 = rasherF[rndData2]; // Timing
(* {32.328125, Null} *)
resulta2 == resultb2
(* True *)