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.