Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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]
share|improve this question
1  
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)? –  Michael E2 Oct 14 '13 at 17:23
add comment

3 Answers

up vote 4 down vote accepted

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

share|improve this answer
add comment

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

share|improve this answer
add comment
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

share|improve this answer
    
Does not work properly with {{0, 1, 0, 1, 1, 1, 0, 1, 1, 1, 1}} –  David Carraher Oct 14 '13 at 20:20
    
@DavidCarraher:I am getting correct output,what error are you getting ? –  Rorschach Oct 14 '13 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. –  David Carraher Oct 14 '13 at 20:42
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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