7
$\begingroup$

I know how to upload images to Mathematica.StackExchange. But what about MeshRegions? That's something I'd like to do frequently. Best would also be a programmatic way to load the region back into Mathematica.

For very simple regions, I can upload some code to generate them or even their coordinates and polygons as plain Mathematica code. But that certainly has its limits. I would also prefer not to use external services as it frequently occured to me that DropBox or Google Drive do not work as expected.

So, is there any way to upload MeshRegions to this site?

$\endgroup$
1
  • $\begingroup$ I feel like this should be migrated to Mathematica Meta since this is a support question for using this particular site... unless the title and usage can be generalized like "How to transfer MeshRegions data as an image?" $\endgroup$
    – Andrew T.
    May 21, 2018 at 2:15

1 Answer 1

9
$\begingroup$

I developed a simple routine ExportMeshRegionAsImage that exports the MeshRegion into two images that can be uploaded to SE.

First, ExportMeshRegionAsImage rescales the coordinates of the MeshRegion R into the unit box and converts the coordinates into an Image of size {MeshCellCount[R,0], RegionEmbeddingDimension[R]} and stores it as png (I use png because it of its lossless compression; that's crucial for not compromising the data). Essentially the same is done with the polygons, but I generate an image from digits of the index list. Currently, only triangle meshes are support because I use the the a color channel per triangle corner.

Options[ExportMeshRegionAsImage] = {
   "RowLength" -> 4096,
   "CoordinateFormat" -> "png",
   "CoordinateOptions" -> {},
   "CellFormat" -> "png",
   "CellOptions" -> {}
   };
ExportMeshRegionAsImage[file_String, R_MeshRegion, OptionsPattern[]] :=
   Module[{pts, triangles, s1, s2, a, b, shift, scale, ϵ, 
    data, rowlen},
   ϵ = 0.0005;
   rowlen = OptionValue["RowLength"];
   pts = MeshCoordinates[R];
   {a, b} = List @@ BoundingRegion[pts];
   shift = 0.5 (a + b);
   pts -= ConstantArray[shift, Length[pts]];
   scale = (1. + 2 ϵ) Max[Abs[b - a]];
   pts /= scale;
   pts += 0.5;
   a = Join[{1.}, 
     Join @@ Riffle[IntegerDigits[Dimensions[pts]]/10., {{1.}}], {1.},
      Flatten[pts]];
   s1 = Export[
     file <> "_pts." <> OptionValue["CoordinateFormat"],
     Image[
      ArrayReshape[a, {Ceiling[Length[a]/(3 rowlen)], rowlen, 3}, 0.],
       "Real"],
     Sequence @@ OptionValue["CoordinateOptions"]
     ];

   data = 
    N[PadLeft[
       IntegerDigits[
        MeshCells[R, RegionDimension[R], "Multicells" -> True][[1, 
          1]]]]]/10.;
   a = Join[
     {1.}, Join @@ Riffle[IntegerDigits[Dimensions[data]]/10., {{1.}}],
     {1.}, Flatten[data]];
   s2 = Export[
     file <> "_cells." <> OptionValue["CellFormat"],
     Image[
      ArrayReshape[a, {Ceiling[Length[a]/(3 rowlen)], rowlen, 3}, 0.]],
     Sequence @@ OptionValue["CellOptions"]
     ];
   Association["CoordinateFile" -> s1, "CellFile" -> s2, 
    "Scale" -> scale, "Shift" -> shift]
   ];

Options[ImportImageAsMeshRegion] = {
   "Scale" -> Automatic,
   "Shift" -> Automatic,
   "CoordinateFormat" -> "tiff",
   "CellFormat" -> "png"
   };

ImportImageAsMeshRegion[a_Association] := Module[{opts},
   opts = Merge[{
      Options[ImportImageAsMeshRegion],
      a
      }, Last];
   ImportImageAsMeshRegion[
    opts["CoordinateFile"], opts["CellFile"], 
    Normal@opts[[Keys[Options[ImportImageAsMeshRegion]]]]
    ]
   ];

ImportImageAsMeshRegion[file_String, opts : OptionsPattern[]] := 
  ImportImageAsMeshRegion[
   file <> "_pts." <> OptionValue["CoordinateFormat"],
   file <> "_cells." <> OptionValue["CellFormat"],
   opts
   ];

ImportImageAsMeshRegion[file1_String, file2_String, 
   OptionsPattern[]] := Module[{pts, cells, cell},
   pts = Module[{a, pos, meta, dims, databegin, dataend},
     a = Flatten[ImageData[Import[file1, "BitDepth" -> 64]]];
     pos = Partition[Flatten[Position[a, 1.]], 2, 1];
     meta = Table[Take[a, p + {1, -1}], {p, pos}];
     dims = 
      FromDigits /@ Round[10. Table[Take[a, p + {1, -1}], {p, pos}]];
     databegin = pos[[-1, -1]] + 1;
     dataend = databegin + Times @@ dims - 1;
     ArrayReshape[a[[databegin ;; dataend]], dims]
     ];
   pts -= 0.5;
   If[NumberQ[OptionValue["Scale"]],
    pts *= OptionValue["Scale"]
    ];
   If[VectorQ[OptionValue["Shift"]],
    pts += ConstantArray[OptionValue["Shift"], Length[pts]]
    ];

   cells = Module[{a, pos, dims, databegin, dataend},
     a = Flatten[ImageData[Import[file2]]];
     pos = Partition[Flatten[Position[a, 1.]], 2, 1];
     dims = 
      FromDigits /@ Round[10. Table[Take[a, p + {1, -1}], {p, pos}]];
     databegin = pos[[-1, -1]] + 1;
     dataend = databegin + Times @@ dims - 1;
     Map[FromDigits, 
      ArrayReshape[Round[10. a[[databegin ;; dataend]]], 
       dims], {Length[dims] - 1}]
     ];
   cell = Switch[Dimensions[cells][[2]],
     2, Line,
     3, Polygon,
     4, Tetrahedron,
     8, Hexahedron
     ];
   If[cell === Tetrahedron && Dimensions[pts][[2]] == 2, 
    cells == Polygon];
   MeshRegion[pts, cell[cells]]

   ];

This is how it works:

Example mesh

R = ExampleData[{"Geometry3D", "StanfordBunny"}, "MeshRegion"];

enter image description here

Exporting:

opts = ExportMeshRegionAsImage["test", R]

<|"CoordinateFile" -> "test_pts.png", "CellFile" -> "test_cells.png", "Scale" -> 0.155855, "Shift" -> {-0.0168404, 0.00153695, 0.110154}|>

You can reinport from file with ImportImageAsMeshRegion[opts]. However, upload to SE will rename the images and this is why there is also a two-argument version of ImportImageAsMeshRegion: The first argument is the image file for the coordinates and the second is for the triangles lists. Optional argumens"Scale" and "Shift" can be given for redoing the normalization that was done during export.

The uploaded images "test_pts.png" and "test_triangles.png" are here:

enter image description here

enter image description here

You can download the images and convert them back with

S = ImportImageAsMeshRegion[
  "https://i.stack.imgur.com/u8G0R.png",
  "https://i.stack.imgur.com/cCdYy.png",
  Normal@opts[[{"Scale", "Shift"}]]
  ]

enter image description here

Since png support only 16 Bit per channel, there is a considerable amount of rounding error:

Max[Abs[MeshCoordinates[R] - MeshCoordinates[S]]]
MeshCells[R, 2, "Multicells" -> True][[1, 1]] == 
 MeshCells[S, 2, "Multicells" -> True][[1, 1]]

1.18906*10^-6

True

This can be repaired by using the tiff format and 64bit color depth"

opts = ExportMeshRegionAsImage["test", R,
   "CoordinateFormat" -> "tiff",
   "CoordinateOptions" -> {"BitDepth" -> 64}
   ];
T = ImportImageAsMeshRegion[opts];
Max[Abs[MeshCoordinates[R] - MeshCoordinates[T]]]

1.38778*10^-17

Unfortunatly, this produces of course a file of significantly larger size that also cannot be uploaded to SE. But 16 bit may suffice for providing simple examples anyway...

$\endgroup$
3
  • $\begingroup$ I was planning on asking and self-answering a question with my workflow on detecting plagarism in Mathematica coursework, but I wanted to include a set of .nb files to make it complete. Would something similar work for that? $\endgroup$
    – SPPearce
    May 20, 2018 at 20:47
  • $\begingroup$ The point here is that a MeshRegion can be fully described by two arrays. The .nb format is much more complicated. You could try to convert the notebook to a String, convert each character to a number between 1/2^16 and 1 export that as a 16 Bit png... $\endgroup$ May 20, 2018 at 20:59
  • $\begingroup$ @KraZug we have a GitHub: github.com/stackmma might be worth putting there. Or your own GitHub pages. halirutan also has a way to compress arbitrary Mathematica expressions as images to put here via his SEUploader, too. $\endgroup$
    – b3m2a1
    May 20, 2018 at 22:15

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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