5
$\begingroup$

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]
$\endgroup$
1
  • 1
    $\begingroup$ 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)? $\endgroup$
    – Michael E2
    Commented Oct 14, 2013 at 17:23

3 Answers 3

5
$\begingroup$

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

Mathematica graphics

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}

Mathematica graphics

$\endgroup$
6
$\begingroup$

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

arrays

$\endgroup$
0
$\begingroup$
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]}]}]

enter image description here

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

enter image description here

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

enter image description here

$\endgroup$
3
  • $\begingroup$ Does not work properly with {{0, 1, 0, 1, 1, 1, 0, 1, 1, 1, 1}} $\endgroup$
    – DavidC
    Commented Oct 14, 2013 at 20:20
  • $\begingroup$ @DavidCarraher:I am getting correct output,what error are you getting ? $\endgroup$ Commented Oct 14, 2013 at 20:38
  • $\begingroup$ 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. $\endgroup$
    – DavidC
    Commented Oct 14, 2013 at 20:42

Your Answer

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

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