3
$\begingroup$

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.

$\endgroup$
1
  • $\begingroup$ 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. $\endgroup$
    – Kane
    May 21, 2014 at 19:04

2 Answers 2

4
$\begingroup$
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).

$\endgroup$
13
  • $\begingroup$ 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} $\endgroup$
    – Kane
    May 21, 2014 at 2:10
  • $\begingroup$ @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? $\endgroup$
    – ciao
    May 21, 2014 at 2:13
  • $\begingroup$ @Kane: Please see updated post. Perhaps you could test, advise if further fleshing-out warranted. Off to munch, but back later... $\endgroup$
    – ciao
    May 21, 2014 at 2:59
  • $\begingroup$ @Kane: Added a string-based method that is pretty quick - give it a whirl. $\endgroup$
    – ciao
    May 21, 2014 at 8:12
  • $\begingroup$ 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. $\endgroup$
    – Kane
    May 21, 2014 at 12:59
1
$\begingroup$

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 *)
$\endgroup$
4
  • $\begingroup$ 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. $\endgroup$
    – Kane
    May 21, 2014 at 19:22
  • $\begingroup$ @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. $\endgroup$
    – kglr
    May 21, 2014 at 21:43
  • $\begingroup$ @kguler: We both over-thought this ;-), see my update. $\endgroup$
    – ciao
    May 21, 2014 at 22:55
  • $\begingroup$ @rasher, a-ha - that confirms the nagging hunch that this should have been much simpler:) $\endgroup$
    – kglr
    May 21, 2014 at 23:00

Your Answer

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

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