# Border on part of ArrayPlot

I need to outline with border the group of cells in ArrayPlot. More precisely in my case I would like to outline all blocks of two black squares in the following line.

ArrayPlot[{{0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1}}, Mesh -> True]

• Would a block of four black squares be outlined as two blocks of two black squares, as in Istvan's answer below? Or would a block of contiguous black squares be outline if its length is exactly two? Or at least two? Or do any two adjacent black squares get outlined (which I assume makes all squares get outlined if there are three or more consecutive black squares)? Commented Oct 14, 2013 at 17:23

I don't think this can be done with Mesh, as this would require non-continuous mesh lines along the horizontal dimension, which (according to my knowledge) is not possible in ArrayPlot. But you can easily create your own array plot. First, I replace each pair of black blocks with placeholders (with {2, 3}) to obtain their positions (where a 2 is), and then create black rectangles over a row of white ones in Graphics:

d = {0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1};

pos = Flatten@Position[(d //. {x___, PatternSequence[1, 1], y___} :> {x, 2, 3, y}), 2];

Graphics[{
MapIndexed[{EdgeForm@Black, FaceForm@GrayLevel[1 - #],
Rectangle[{First@#2, 0}, {First@#2 + 1, 1}]} &, d],
{EdgeForm@{Red, Thick}, Rectangle[{#, 0}, {# + 2, 1}]} & /@ pos
}]


This works for any list, even ones with excess black blocks (note that it starts blocks from the left):

d = {1, 0, 1, 1, 1, 1, 1, 0, 0, 0, 1, 0, 1, 1, 1}


Here's one way, using ArrayPlot along with Epilog:

g[data_] :=  Module[{f}, f[{_} | {}, r_] := r;
f[{a_, b_, c___}, s_] := If[b == a + 1, f[{c}, Append[s, a]], f[{b, c}, s]];
ArrayPlot[data, Mesh -> True, Epilog -> {Orange, Thickness[.01],
Line[{{#, 0}, {# + 2, 0}, {# + 2, 1}, {#, 1}, {#, 0}}] & /@
f[(Position[data, 1][[All, 2]] - 1), {}]}]]


Examples

g[{{0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1}}]
g[{{1, 0, 1, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1}}]


Style[Grid[{{0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1}},
Frame -> True] /. {x_?OddQ ->
Item[x, Background -> Green, ItemSize -> 2, Frame -> True,
FrameStyle -> {Thick, Directive[Red, 12]}]}]


Corrected Version: Initially I didn't pay attention on it being blocks of two, which I have corrected now,

Block[{t, t1,
t2}, {t = {0, 1, 0, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1} //. {a___, c_ 1, c_ 1, b___} -> {a, {c, 2}, b};
t1 = t /. {{a_, b_}, c_} -> Apply[Sequence, {{a, b}, {a, c}}],
t2 = t1 /. {a_, b_} -> ConstantArray[1, 2]};
Grid[{t2},
Frame -> True] /. {x_?eq ->
Item[x, Background -> Green, Frame -> True,
FrameStyle -> {Thick, Directive[Red, 12]}]}]
eq[x_] := Equal[x, {1, 1}]


In case of {0, 1, 1, 1, 0, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1}

• Does not work properly with {{0, 1, 0, 1, 1, 1, 0, 1, 1, 1, 1}} Commented Oct 14, 2013 at 20:20
• @DavidCarraher:I am getting correct output,what error are you getting ? Commented Oct 14, 2013 at 20:38
• The "bits" with 1 should not be wrapped individually, but rather by pairs. Also, for the data I provided, there should be no border around the 1 at positions 2 and 6. See my second example or István's first. Commented Oct 14, 2013 at 20:42