4
$\begingroup$

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:

enter image description here

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

enter image description here

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

$\endgroup$
1
$\begingroup$

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

enter image description here

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}]
$\endgroup$
3
  • $\begingroup$ 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. $\endgroup$ – Cham Dec 5 '20 at 17:07
  • $\begingroup$ @Cham I had rewrite the code, only use the functions which come from Mathematica 7. $\endgroup$ – cvgmt Dec 6 '20 at 2:00
  • $\begingroup$ 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... $\endgroup$ – Cham Dec 6 '20 at 2:21
0
$\begingroup$
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]
   ];
$\endgroup$
6
  • $\begingroup$ The last block of code doesn't do anything on my system. Really, v7 is simply too old. $\endgroup$ – Cham Dec 5 '20 at 18:18
  • $\begingroup$ @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.) $\endgroup$ – Michael E2 Dec 5 '20 at 18:24
  • $\begingroup$ ok, sorry, I'll try this in a few minutes... $\endgroup$ – Cham Dec 5 '20 at 18:25
  • $\begingroup$ @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.) $\endgroup$ – Michael E2 Dec 5 '20 at 18:48
  • $\begingroup$ @Cham Did it work? $\endgroup$ – Michael E2 Dec 5 '20 at 22:11
0
$\begingroup$
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]

enter image description here

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]

enter image description here

$\endgroup$
6
  • $\begingroup$ 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.>> $\endgroup$ – Cham Dec 5 '20 at 16:57
  • $\begingroup$ 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]] $\endgroup$ – Cham Dec 5 '20 at 17:28
  • $\begingroup$ how about v7regionFunc[Rationalize[polygongroups[[1, 1]]]]? $\endgroup$ – kglr Dec 5 '20 at 17:32
  • $\begingroup$ I get the same as previously said $\endgroup$ – Cham Dec 5 '20 at 17:51
  • $\begingroup$ @Cham, please try the new method. $\endgroup$ – kglr Dec 5 '20 at 18:27

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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