a workaround for large EPS files from ContourPlot
- To: mathgroup at smc.vnet.net
- Subject: [mg87388] a workaround for large EPS files from ContourPlot
- From: "mikelito at gmail.com" <mikelito at gmail.com>
- Date: Wed, 9 Apr 2008 05:55:42 -0400 (EDT)
As others have noticed in previous posts, if one exports an EPS from a
ContourPlot produced by Mathematica6, the result is far from being
satisfactory. The EPS is one order of magnitude larger in size than
the one generated by Math5 in similar situations, and displays ugly
artefacts when viewed on screen.
The problem comes from the fact that the plot is generated internally
by a recursive method, producing a dense mesh of triangles even where
the function is flat and there is a large monochromatic surface.
I think this approach is incredibly inefficient, and I hope that
future versions will fix this issue. In the meantime I came up with a
package to heal the problem. Basically, the triangles are iteratively
collapsed forming larger polygons and deleting useless segments.
The function is rather slow, as a lot of complex pattern substitutions
must be performed. If someone is able to make it faster, it would be
great. However, it works. I experienced savings in EPS size from a
factor of 5 up to 50, depending on the complexity of the initial
plot.
If you need an EPS of reasonable size, this is a viable workaround. I
hope someone will benefit of this.
Michele Ceriotti
Package source code follows, the syntax is simply
cp=ContourPlot[ ..... ]
scp=ClearCP[cp]
*****************************************************************
(* ::Package:: *)
BeginPackage["ClearCP`", {"Utilities`FilterOptions`","StatusBar`"}]
Options[ClearCP]={MaxRecursion->10000, Debug->True};
ClearCP::usage = "ClearCP[contourplot,options] recursively simplify
the mesh used internally to draw the fillup of the contours,
reducing greatly the size of exported EPS";
Begin["Private`"]
Module[{
patjoin,rulejoin,ruleclean,w1,w2,z1,z2,p1,p2,k1,k2,
zl,pl,i,j,pair,tpair,
ol,nl,ip},
patjoin=({{p2_,___,p1_},{p1_,___,p2_}}|{{___,p1_,p2_,___},
{p1_,___,p2_}}|
{{p2_,___,p1_},{___,p2_,p1_,___}}|{{___,p1_,p2_,___},
{___,p2_,p1_,___}});
rulejoin={{{w1___,p1_,p2_,w2___},{z1___,p2_,p1_,z2___}}-
>{w1,p1,z2,z1,p2,w2},{{w1___,p1_,p2_,w2___},{p1_,z1___,p2_}}-
>{w1,p1,z1,p2,w2},
{{p2_,w1___,p1_},{z1___,p2_,p1_,z2___}}->{w1,p1,z2,z1,p2},
{{p2_,w1___,p1_},{p1_,z1___,p2_}}->{w1,p1,z1,p2}};
ruleclean={{k1___,p1_,p2_,p1_,k2___}->{k1,p1,k2},
{p1_,k1___,p1_}->{k1,p1},
{p2_,p1_,k1___,p1_}->{k1,p1},
{p1_,k1___,p1_,p2_}->{k1,p1}
};
purify[l_]:=(
zl=l; pl={};Replace[If[Length[zl]==1,zl,
i=1;j=2;
pl=Reap[
While[i<Length[zl],
pair={zl[[i]],zl[[j]]};
If[
Length[Intersection[zl[[i]],zl[[j]]]]>1
&&
MatchQ[pair,patjoin],
Sow[(pair/.rulejoin)];
zl=Delete[zl,{{i},{j}}];i=1;j=1;];
j++;If[j>Length[zl],i++;j=i+1]
]];
pl=Flatten[pl[[2]],1];
Join[pl,zl]//.ruleclean],{{k1__},{k2__}}->Sequence[{k1},{k2}],1]
);
];
Module[
{
i,j,k,,w1,w2,w3,
cl, clr,clp, clsimp,
pl, plr, plp, plsimp,ppos, pnp, lpnp
},
SimplifyGC[gc_GraphicsComplex,OptionsPattern[ClearCP]]:=(
cl=gc[[2,2]];
clr=Union[Flatten[Cases[cl,Line[k__]:>k,Infinity]]];
clp=gc[[1,clr]];
clr=Table[clr[[i]]->i,{i,1,Length[clr]}];
clsimp=GraphicsComplex[clp,cl/.clr];
(*first simplification of polygon, we take only the relevant
points*)
pl=gc[[2,1]];
plr=Union[Flatten[Cases[pl,Polygon[k_List,___]:>k,Infinity]]];
plp=gc[[1,plr]];
plr=Table[plr[[i]]->i,{i,1,Length[plr]}];
(*then we collapse polygons.*)
(*first we get rid of graphicsgroups*)
pl=pl//.
{GraphicsGroup[{Polygon[w1_List,___],Polygon[w2_List,___],w3___}]-
>GraphicsGroup[{Polygon[Join[w1,w2]],w3}],
GraphicsGroup[{Polygon[w1_List,___]}]->Polygon[w1]};
(*then we simplify the vertex lists of the polygons*)
ppos=Position[pl,_Polygon];
Do[
pnp=pl[[Sequence@@ppos[[i]]]][[1]];
If[OptionValue[Debug]==True,
Print["Simplifying contour ",i," of ",Length[ppos],". N. segs:
",Length[pnp]]];
Do[
lpnp=Length[pnp];
pnp=purify[pnp];
If[Length[pnp]==lpnp,Break[]],{j,1,OptionValue[MaxRecursion]}];
pl[[Sequence@@ppos[[i]]]]=Polygon[pnp];
,{i,1,Length[ppos]}];
(*final removal of extra points*)
plsimp=GraphicsComplex[plp,pl/.plr];
{plsimp,clsimp}
);
];
Module[{h},
ClearCP[cp__Graphics,OptionsPattern[ClearCP]]:=(
cp/.(h_GraphicsComplex:> SimplifyGC[h,
MaxRecursion->OptionValue[MaxRecursion],Debug->OptionValue[Debug]])
)
]
End[];
EndPackage[];