# How to draw borders around tiles of the same color?

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).

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

• In your first code above (for Mma 7), the asterisk * is causing a compilation problem: Syntax::sntxf : "Last@" cannot be followed by "*Last@pts[[#]]". "Last@" is complete; more input is needed.
– Cham
Dec 5, 2020 at 17:07
• @Cham I had rewrite the code, only use the functions which come from Mathematica 7. Dec 6, 2020 at 2:00
• I tried your last edit, but it gives me a lot of error messages, like this: Map::argtu: Map called with 1 argument; 2 or 3 arguments are expected. >> RegionPlot::pllim: Range specification PlotStyle->colors[[i]] is not of the form {x, xmin, xmax}. Part::pspec: Part specification i is neither an integer nor a list of integers. Show::gcomb: Could not combine the graphics objects in Show...
– Cham
Dec 6, 2020 at 2:21
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]
];

• The last block of code doesn't do anything on my system. Really, v7 is simply too old.
– Cham
Dec 5, 2020 at 18:18
• @Cham That's too bad. I'm confused that it "doesn't do anything." It should do something, even if it's wrong. "The last block of code" is literally just definitions and has no output. You have to execute the last block and then the first block. (Your phrasing made me wonder if you did that. Sorry if it was confusing.) Dec 5, 2020 at 18:24
• ok, sorry, I'll try this in a few minutes...
– Cham
Dec 5, 2020 at 18:25
• @Cham Another thing I did that I forgot: I changed some of the variables to start with lowercase. (That's my personal style, nothing very important, but if you didn't notice, it might mess things up.) Dec 5, 2020 at 18:48
• @Cham Did it work? Dec 5, 2020 at 22:11
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},


Extract the polygon groups from lcp:

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


Use GraphicsPolygonUtilsPolygonCombine to combine each group of polygons and render the borders only (FaceForm[]):

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


Combine lcp and borders using Show:

Show[lcp, borders, PlotRange -> All]


• I'm getting some error messages when I compile your code: Part::part: Part 2 of Polygon[{{0.8795...}}] does not exist.>> General::stop: Further output of Part::parts will be suppressed during this calculation.>>
– Cham
Dec 5, 2020 at 16:57
• I get {106, 101, 97, 105, 91}, and Region'RegionProperty[Polygon[{{0.907002, 0.269816},{0.942153, 0.310433},{0.890225, 0.330503}}], {x,y}, FastDescription][[1,2]]
– Cham
Dec 5, 2020 at 17:28
• how about v7regionFunc[Rationalize[polygongroups[[1, 1]]]]?
– kglr
Dec 5, 2020 at 17:32
• I get the same as previously said
– Cham
Dec 5, 2020 at 17:51
• @Cham, please try the new method.
– kglr
Dec 5, 2020 at 18:27