How to draw borders around tiles of the same color?

Question

I'm having difficulties with a project to show random tiles with a few random colors. Here's the code that I need to modify:

Ndomain = 500; (* Number of tiles *)
 
RandomTiles = 
 Table[{RandomReal[], RandomReal[], RandomInteger[{1, 5}]}, {n, 1, 
   Ndomain}];

ListContourPlot[RandomTiles,
 Mesh -> None,
 MeshStyle -> Thick,
 ColorFunction -> "CandyColors",
 InterpolationOrder -> 0,
 Frame -> False,
 ImageSize -> {500, 500}
 ]

ListPlot3D[DomainesAleatoires,
 Mesh -> All,
 MeshStyle -> Thick,
 ColorFunction -> "CandyColors",
 InterpolationOrder -> 0,
 ImageSize -> {500, 500}
 ]

Preview of what this code is doing:

Now the problem: In the 2D view, I need to draw a thick black line around all adjacent tiles that have the same color, something like this (it's similar to the question Draw border around constant regions of image, but this is about another problem):

How could I do that? Take note that I'm using Mathematica 7.0, so I need minimalistic modifications to the code above (unless it's actually impossible to do and need to rebuilt completely the code).

Answer 1

Edit: Mathematica 7

All of the function is come from Version 7. But it seems that the RegionPlot have updated more from version 7.

Ndomain = 500;
levels = 5;
RandomTiles = 
  Table[{RandomReal[], RandomReal[], RandomInteger[{1, levels}]}, {n, 
    1, Ndomain}];
graph = ListPlot3D[RandomTiles, InterpolationOrder -> 0, Mesh -> None,
    Axes -> False, Boxed -> False];
pts = Cases[graph, GraphicsComplex[x___] :> x, Infinity] // First;
polygons = Cases[graph, GraphicsGroup[x___] :> x, Infinity] // First;
indexs = Level[polygons, {-2}];
groupindexs = GatherBy[indexs, Last[Last@pts[[#]]] &];
grouppts = Map[Drop[#, -1] & /@ pts[[#]] &] /@ groupindexs;
length = Length@groupindexs;
colors = ColorData["CandyColors"] /@ Range[0, 1, 1/length];
regs = Polygon /@ grouppts;
Table[RegionPlot[regs[[i]], PlotStyle -> colors[[i]], Frame -> False, 
   BoundaryStyle -> {White, Thick}], {i, 1, length}] // Show

Original:2D Method

OK! I found a way suitable for Mathematica 7.0 and it is a 2D method,not just 3D method.

Ndomain = 500; 
levels = 5; 
RandomTiles = 
 Table[{RandomReal[], RandomReal[], RandomInteger[{1, levels}]}, {n, 
   1, Ndomain}];
graph = ListPlot3D[RandomTiles, InterpolationOrder -> 0, Mesh -> None,
    Axes -> False, Boxed -> False];
pts = Cases[graph, GraphicsComplex[x___] :> x, Infinity] // First;
polygons = Cases[graph, GraphicsGroup[x___] :> x, Infinity] // First;
indexs = Level[polygons, {-2}];
groupindexs = 
  GroupBy[indexs, Last[Last@pts[[#]]] &, 
   Map[Drop[#, -1] & /@ pts[[#]] &]];
regs = Polygon /@ groupindexs // Values;
colors = ColorData["CandyColors"] /@ Subdivide[0, 1, levels];
Table[RegionPlot[regs[[i]], PlotStyle -> colors[[i]], Frame -> False, 
   BoundaryStyle -> {White, Thick}], {i, 1, levels}] // Show

Original: 3D method

I can't find the way suitable for Mathematica 7.0.

So here just provided a idea.

Ndomain = 500;(*Number of tiles*)RandomTiles = 
 Table[{RandomReal[], RandomReal[], RandomInteger[{1, 5}]}, {n, 1, 
   Ndomain}];
graph = ListPlot3D[RandomTiles, InterpolationOrder -> 0];
regs = DiscretizeGraphics[graph];
RegionPlot3D[regs, ViewPoint -> {0, 0, Infinity}, Boxed -> False, 
 BoundaryStyle -> Thick, 
 ColorFunction -> Function[{x, y, z}, ColorData["CandyColors"][z]], 
 ColorFunctionScaling -> True, ImageSize -> {500, 500}]

Answer 2

SeedRandom[0];
ndomain = 500;(*Number of tiles*)
randomTiles = 
 Table[{RandomReal[], RandomReal[], RandomInteger[{1, 5}]},
   {n, 1, ndomain}];

plot = ListContourPlot[randomTiles, Mesh -> All, MeshStyle -> Thick, 
   ColorFunction -> "CandyColors", InterpolationOrder -> 0, 
   Frame -> False, ImageSize -> {400, 400}];

(* code for functions given below -- takes about 1.5s for me *)
plot // gatherPolys // deleteDuplicatePointsGC // boundaryEdges // 
 findBoundary (* optional last step takes most of the time *)

Code dump

I don't have V7, so I tried to stick to system commands that the docs say were introduced in V7 or earlier. Possibly the way they function has changed. Hopefully, each the polygons of the same color are all gathered in single GraphicsGroup. NearestFunction has changed, but I think the form I use is okay in V7.

ClearAll[gatherPolys, boundaryEdges, findBoundary, findLoops, 
  mergeEdges];

gatherPolys[plot_] := (* GraphicsGroup[{Polygon[..], Polygon[..],..}] *)
  plot /. pp : {__Polygon} :> Join @@@ Thread[pp, Polygon];

(* points are duplicated in ListContourPlot
 *   which makes identifying the same edge more complicated
 * this combines duplicates so that edges can be identified 
 *   by having the same GC indices  *)
deleteDuplicatePointsGC[graphics_] := graphics /. GraphicsComplex[
     pts_,
     g_,
     opts___] :>
    Module[{redpts, nf},
     redpts = DeleteDuplicates@pts;
     nf = Nearest[redpts -> Automatic];
     GraphicsComplex[
      redpts,
      g /. (prim : Line | Polygon)[
          p_ /; VectorQ[Flatten@p, IntegerQ]] :> 
         prim[(Flatten@nf[pts[[#]]] & /@ p)] /. _EdgeForm -> 
        EdgeForm[],
      opts
      ]
     ];

(* Boundary edges occur only once in a group of polygons
 * Internal edges occur twice  *)
boundaryEdges[g_, style_ : Directive[Thick, Black]] := 
  g /. Polygon[p_] :> 
    With[{edges = 
       Flatten[murf = p; Partition[#, 2, 1, 1] & /@ p, 1]},
     With[{sa = SparseArray[edges -> 1, {Max[p], Max[p]}]},
      foo = sa;
      {Polygon[p],
       {style,
        Annotation[
         Line[
          Position[Normal@UpperTriangularize@(sa + Transpose@sa), 
           1]],
         "Boundary"]}}
      ]
     ];

(* at this point  g  has the boundary edges as line segments
 *   and a reasonable plot is generated without converting them
 *   to polygons
 * but it is nicer to connect them together which is done here  *)
findBoundary[g_, style_ : {Thick, Black}] := 
  g /. Annotation[Line[p_], "Boundary"] :> {
     EdgeForm[style], Opacity[0],
     Polygon[p // findLoops]};
findLoops[p_] := FixedPoint[mergeEdges, p, 10];
mergeEdges[edges_] := Module[{subQ = True},
   Fold[
    (subQ = True;  (* only one sub per iteration *)
      # /.
           e : {___, First[#2]} /; subQ :>
            Join[subQ = False; e, Rest[#2]] /.
          e : {___, Last[#2]} /; subQ :>
           Join[subQ = False; e, Reverse@Most[#2]] /.
         e : {First[#2], ___} /; subQ :>
          Join[subQ = False; Reverse@Rest[#2], e] /.
        e : {Last[#2], ___} /; subQ :>
         Join[subQ = False; Most[#2], e] /.
       all_ /; subQ :> Append[all, #2]
      ) &,
    {},
    edges]
   ];

Answer 3

Ndomain = 500;
SeedRandom[1]
RandomTiles = Table[{RandomReal[], RandomReal[], RandomInteger[{1, 5}]}, 
    {n, 1, Ndomain}];

lcp = ListContourPlot[RandomTiles, 
    ColorFunction -> ColorData["CandyColors"], InterpolationOrder -> 0,
    Frame -> False, ImageSize -> {500, 500}, 
    PlotRangePadding -> None, ImagePadding -> None]

Extract the polygon groups from lcp:

polygongroups = Cases[Normal[lcp[[1]]], GraphicsGroup[x_] :> Flatten @ x, {1, ∞}];

Use Graphics`PolygonUtils`PolygonCombine to combine each group of polygons and render the borders only (FaceForm[]):

borders = Graphics[{EdgeForm[ Thick], FaceForm[], 
      Graphics`PolygonUtils`PolygonCombine@#} & /@ polygongroups];

Combine lcp and borders using Show:

Show[lcp, borders, PlotRange -> All]