# Replacing Patterns In a List of Varying Length

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.

-
I also forgot something in my test data above. These numbers are floating point numbers, as it is much faster to manipulate large arrays using floating point numbers. So, my data looks something like this. – Kane May 21 '14 at 19:04

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

-
Thanks. I knew there was probably a way to do it without indexing through it. Hopefully this will be fast. I am working with arrays on the order of {100,100000} – Kane May 21 '14 at 2:10
@Kane: this kind of pattern matching can get slow. I'd venture for large arrays you'll need something clever. I'll ponder it...BTW- you say in OP "exceeds 2", but your example includes 2 length. Which is the intent? – ciao May 21 '14 at 2:13
@Kane: Please see updated post. Perhaps you could test, advise if further fleshing-out warranted. Off to munch, but back later... – ciao May 21 '14 at 2:59
@Kane: Added a string-based method that is pretty quick - give it a whirl. – ciao May 21 '14 at 8:12
Ultimately, for the large arrays I am working with, what I want to do is replace any sequence of ones that are larger than 100 or maybe even 1000. I'm not sure yet. What I posted above was an example of what I am trying to do at a smaller scale so I can propose the question. – Kane May 21 '14 at 12:59

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

-
This method appears to work with the test data above. However, when I use data on the order of {792001,111}, for some reason it doesn't work anymore. For some reason it yielded {792001,104} array and it didn't replace any patterns of 1 to 0. – Kane May 21 '14 at 19:22
@Kane,I think this version fixes the problem (used the second argument of PadLeft to pad with the right number of zeros). It now gives the same output as rasher's method, but it is still considerably slower. – kglr May 21 '14 at 21:43
@kguler: We both over-thought this ;-), see my update. – ciao May 21 '14 at 22:55
@rasher, a-ha - that confirms the nagging hunch that this should have been much simpler:) – kglr May 21 '14 at 23:00