Related
I have a data set with x,y and error(y) values. I write this in mathematica as:
Needs["ErrorBarPlots`"]
data = {{{0, 0.10981309359605919},
ErrorBar[0.05240427422664753`]}, {{0.2145, 0.09146326059113304},
ErrorBar[0.034195343626358385`]}, {{0.4290, 0.08230438177339898},
ErrorBar[0.02533205817067696`]}, {{0.6435, 0.0768141842364532},
ErrorBar[0.020205473852635995`]}, {{0.8580, 0.07223473349753692},
ErrorBar[0.016156209168991867`]}, {{4, 0.056122650246305375},
ErrorBar[0.009288720442961331]}};
ErrorListPlot[data, Frame -> True, FrameStyle -> Directive[Black, 20],
PlotRange -> {{-0.1, 5}, {0.2, 0}}, Axes -> False,
PlotStyle -> {Directive[Red, 12], AbsolutePointSize[10],
AbsoluteThickness[3]} , LabelStyle -> Directive[Green],
BaseStyle -> {Large, FontFamily -> "Courier", FontSize -> 12}]
But what I am trying to obtain is draw a line and get a shaded error band connecting the errorbars which obey a functional form, f(x)= 0.05 + 0.02/(x^2 + 0.425) . I don't want to show the error bars explicitly , rather I want to show the band. I am looking for something like this
I have looked at this link http://reference.wolfram.com/language/howto/GetResultsForFittedModels.html
but couldn't solve the problem. Could anyone please help me? Thanks.
Here is one approach, make two lists, one list for upper range of the erros:
dataPLUS = {{0, 0.10981309359605919 + 0.05240427422664753`}, {0.2145,
0.09146326059113304 + 0.034195343626358385`}, {0.4290,
0.08230438177339898 + 0.02533205817067696`}, {0.6435,
0.0768141842364532 + 0.020205473852635995`}, {0.8580,
0.07223473349753692 + 0.016156209168991867`}, {4,
0.056122650246305375 + 0.009288720442961331}};
another list for the lower range of the errors as:
dataMINUS = {{0, 0.10981309359605919 - 0.05240427422664753`}, {0.2145,
0.09146326059113304 - 0.034195343626358385`}, {0.4290,
0.08230438177339898 - 0.02533205817067696`}, {0.6435,
0.0768141842364532 - 0.020205473852635995`}, {0.8580,
0.07223473349753692 - 0.016156209168991867`}, {4,
0.056122650246305375 - 0.009288720442961331}};
Once you have the two sets you can use the ListPlot option as:
ListPlot[{dataPLUS, dataMINUS}, PlotStyle -> Red, PlotRange -> All]
which will generate a graph like
if you want to join them, instead use ListLinePlot option
ListLinePlot[{dataPLUS, dataMINUS}, PlotStyle -> Red,PlotRange -> All]
and to have a shaded region in between, use the Filling option
ListLinePlot[{dataPLUS, dataMINUS}, PlotStyle -> Red, Filling -> {1 -> {{2}, Gray}}, PlotRange -> All]
To get smooth graph, you need more data points. Hope this will help.
And to include the BestFit line, define a function and add to the previous plots as:
f[x_] = 0.05 + 0.02/(x^2 + 0.425);
plot2 = Plot[f[x], {x, 0, 5}, PlotStyle -> {Red, Thick}];
plot1 = ListLinePlot[{dataPLUS, dataMINUS}, PlotStyle -> LightGray,Filling -> {1 -> {{2}, LightGray}}, PlotRange -> All];
Show[{plot1, plot2}]
I have a cloud of points in 3D. It is easy to plot them with Mathematica with ListPlot3D function. The coloring is a bit difficult for me. I would like to get a result like this:
SphericalPlot3D[
1 + Sin[-5 \[Phi]] Sin[-5 \[Theta]]/10, {\[Theta],
0, \[Pi]}, {\[Phi], 0, 2 \[Pi]},
ColorFunction -> (ColorData["Rainbow"][#6] &), Mesh -> None,
PlotPoints -> 30, Boxed -> False, Axes -> False]
So that color would show the radial distance from the center. Is it possible to do it? I also have very near spherical cloud of data, more precisely spherical-like cap with bulges.
You can do :
nPoints = 10^3;
SeedRandom[7];
data = CoordinateTransformData["Spherical" -> "Cartesian", "Mapping", #] & /#
Transpose[{1 + RandomReal[{-0.15, 0.15}, nPoints], RandomReal[{0, Pi}, nPoints], RandomReal[{-Pi, Pi}, nPoints]}];
ListSurfacePlot3D[data,
ColorFunction -> (ColorData["Rainbow"][EuclideanDistance[{0, 0, 0},{#1, #2, #3}]] &),
ColorFunctionScaling -> False, Mesh -> None, Boxed -> False, Axes -> False]
I'm modelling the gravity field of the eight planets and trying to export the resulting ContourPlot as a .avi file. The problem is that the .avi plays the animation both forwards and backwards, even though I explicitly tell Animate that AnimationDirection->Forward. Anyone know any solutions? Here's the offending piece of code:
gfield = Animate[
ContourPlot[
Sqrt[Fgravplanets[x, y, t][[1]]^2 + Fgravplanets[x, y, t][[2]]^2],
{x, -1.5 rp["Neptune"], 1.5 rp["Neptune"]}, {y, -1.5 rp["Neptune"],
1.5 rp["Neptune"]},
PlotRange -> {0, 10},
Mesh -> None,
ImageSize -> Medium,
AxesLabel -> {"x", "y", "Fgrav"},
ColorFunction -> Hue,
PlotPoints -> 20,
Contours -> 20
],
{t, 0, 365*24*3600*10, 365*24*3600/10},
AnimationDirection -> Forward,
AnimationRate -> 365*24*3600/5
]
Export["gfield.avi", gfield]
Just replace Animate by Table:
gfield = Table[
ContourPlot[
Sqrt[Fgravplanets[x, y, t][[1]]^2 + Fgravplanets[x, y, t][[2]]^2],
{x, -1.5 rp["Neptune"], 1.5 rp["Neptune"]}, {y, -1.5 rp["Neptune"],
1.5 rp["Neptune"]},
PlotRange -> {0, 10},
Mesh -> None,
ImageSize -> Medium,
AxesLabel -> {"x", "y", "Fgrav"},
ColorFunction -> Hue,
PlotPoints -> 20,
Contours -> 20
],
{t, 0, 365*24*3600*10, 365*24*3600/10}];
Export["gfield.avi", gfield]
Exporting to .avi works as expected for lists of graphics. You might have to adjust the step size in the Table iterator to achieve your desired framerate.
Here is a set of structured 3D points. Now we can form a BSpline using these points as knots.
dat=Import["3DFoil.mat", "Data"]
fu=BSplineFunction[dat]
Here we can do a ParametricPlot3D with these points.
pic=ParametricPlot3D[fu[u,v],{u, 0, 1}, {v, 0, 1}, Mesh -> All, AspectRatio ->
Automatic,PlotPoints->10,Boxed-> False,Axes-> False]
Question
If we carefully look at the 3D geometry coming out of the spline we can see that it is a hollow structure. This hole appears in both side of the symmetric profile. How can we perfectly (not visually!) fill up this hole and create a unified Graphics3D object where holes in both sides are patched.
What I am able to get so far is the following. Holes are not fully patched.
I am asking too many questions recently and I am sorry for that. But if any of you get interested I hope you will help.
Update
Here is the problem with belisarius method.
It generates triangles with almost negligible areas.
dat = Import[NotebookDirectory[] <> "/3DFoil.mat", "Data"];
(*With your points in "dat"*)
fd = First#Dimensions#dat;
check = ParametricPlot3D[{BSplineFunction[dat][u, v],
BSplineFunction[{dat[[1]], Reverse#dat[[1]]}][u, v],
BSplineFunction[{dat[[fd]], Reverse#dat[[fd]]}][u, v]}, {u, 0,
1}, {v, 0, 1}, Mesh -> All, AspectRatio -> Automatic,
PlotPoints -> 10, Boxed -> False, Axes -> False]
output is here
Export[NotebookDirectory[]<>"myres.obj",check];
cd=Import[NotebookDirectory[]<>"myres.obj"];
middle=
check[[1]][[2]][[1]][[1(* Here are the numbers of different Graphics group*)]][[2,1,1,1]];
sidePatch1=check[[1]][[2]][[1]][[2]][[2,1,1,1]];
sidePatch2=check[[1]][[2]][[1]][[3]][[2,1,1,1]];
There are three Graphics groups rest are empty. Now lets see the area of the triangles in those groups.
polygonArea[pts_List?
(Length[#]==3&)]:=Norm[Cross[pts[[2]]-pts[[1]],pts[[3]]-pts[[1]]]]/2
TriangleMaker[{a_,b_,c_}]:={vertices[[a]],vertices[[b]],vertices[[c]]}
tring=Map[polygonArea[TriangleMaker[#]]&,middle];
tring//Min
For the middle large group output is
0.000228007
This is therefore a permissible triangulation. But for the side patches we get zero areas.
Map[polygonArea[TriangleMaker[#]] &, sidePatch1] // Min
Map[polygonArea[TriangleMaker[#]] &, sidePatch2] // Min
Any way out here belisarius ?
My partial solution
First download the package for simplifying complex polygon from Wolfram archive.
fu = BSplineFunction[dat];
pic =(*ParametricPlot3D[fu[u,v],{u,0,1},{v,0,1},Mesh->None,
AspectRatio->Automatic,PlotPoints->25,Boxed->False,Axes->False,
BoundaryStyle->Red]*)
ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1}, Mesh -> None,
AspectRatio -> Automatic, PlotPoints -> 10, Boxed -> False,
Axes -> False, BoundaryStyle -> Black];
bound = First#Cases[Normal[pic], Line[pts_] :> pts, Infinity];
corners = Flatten[Table[fu[u, v], {u, 0, 1}, {v, 0, 1}], 1];
nf = Nearest[bound -> Automatic]; {a1, a2} =
Union#Flatten#(nf /# corners);
sets = {bound[[2 ;; a1]], bound[[a1 ;; a2]],bound[[a2 ;; a2 + a1]]};
CorrectOneNodeNumber = Polygon[sets[[{1, 3}]]][[1]][[1]] // Length;
CorrectOneNodes1 =
Polygon[sets[[{1, 3}]]][[1]][[1]]; CorrectOneNodes2 =
Take[Polygon[sets[[{1, 3}]]][[1]][[2]], CorrectOneNodeNumber];
<< PolygonTriangulation`SimplePolygonTriangulation`
ver1 = CorrectOneNodes1;
ver2 = CorrectOneNodes2;
triang1 = SimplePolygonTriangulation3D[ver1];
triang2 = SimplePolygonTriangulation3D[ver2];
Show[Graphics3D[{PointSize[Large], Point[CorrectOneNodes1]},Boxed -> False,
BoxRatios -> 1], Graphics3D[{PointSize[Large], Point[CorrectOneNodes2]},
Boxed -> False, BoxRatios -> 1],
Graphics3D[GraphicsComplex[ver1, Polygon[triang1]], Boxed -> False,
BoxRatios -> 1],
Graphics3D[GraphicsComplex[ver2, Polygon[triang2]], Boxed -> False,
BoxRatios -> 1]]
We get nice triangles here.
picfin=ParametricPlot3D[fu[u,v],{u,0,1}, {v,0,1},Mesh->All,AspectRatio->Automatic,PlotPoints->10,Boxed->False,Axes->False,BoundaryStyle->None];pic3D=Show[Graphics3D[GraphicsComplex[ver1,Polygon[triang1]]],picfin,Graphics3D[GraphicsComplex[ver2,Polygon[triang2]]],Boxed->False,Axes->False]
Now this has just one problem. Here irrespective of the PlotPoints there are four triangles always appearing that just shares only one edge with any other neighboring triangle. But we expect all of the triangles to share at least two edges with other trangles. That happens if we use belisarius method. But it creates too small triangles that my panel solver rejects as tingles with zero area.
One can check here the problem of my method. Here we will use the method from the solution by Sjoerd.
Export[NotebookDirectory[]<>"myres.obj",pic3D];
cd=Import[NotebookDirectory[]<>"myres.obj"];
polygons=(cd[[1]][[2]]/.GraphicsComplex-> List)[[2]][[1]][[1,1]];
pt=(cd[[1]][[2]]/.GraphicsComplex-> List)[[1]];
vertices=pt;
(*Split every triangle in 3 edges,with nodes in each edge sorted*)
triangleEdges=(Sort/#Subsets[#,{2}])&/#polygons;
(*Generate a list of edges*)
singleEdges=Union[Flatten[triangleEdges,1]];
(*Define a function which,given an edge (node number list),returns the bordering*)
(*triangle numbers.It's done by working through each of the triangles' edges*)
ClearAll[edgesNeighbors]
edgesNeighbors[_]={};
MapIndexed[(edgesNeighbors[#1[[1]]]=Flatten[{edgesNeighbors[#1[[1]]],#2[[1]]}];
edgesNeighbors[#1[[2]]]=Flatten[{edgesNeighbors[#1[[2]]],#2[[1]]}];
edgesNeighbors[#1[[3]]]=Flatten[{edgesNeighbors[#1[[3]]],#2[[1]]}];)&,triangleEdges];
(*Build a triangle relation table.Each'1' indicates a triangle relation*)
relations=ConstantArray[0,{triangleEdges//Length,triangleEdges//Length}];
Scan[(n=edgesNeighbors[##];
If[Length[n]==2,{n1,n2}=n;
relations[[n1,n2]]=1;relations[[n2,n1]]=1];)&,singleEdges]
(*Build a neighborhood list*)
triangleNeigbours=Table[Flatten[Position[relations[[i]],1]],{i,triangleEdges//Length}];
trires=Table[Flatten[{polygons[[i]],triangleNeigbours[[i]]}],{i,1,Length#polygons}];
Cases[Cases[trires,x_:>Length[x]],4]
Output shows always there are four triangles that shares only one edges with others.
{4,4,4,4}
In case of belisarius method we don't see this happening but there we get triangles with numerically zero areas.
BR
Import the data and construct the BSpline function as before:
dat = Import["Downloads/3DFoil.mat", "Data"];
fu = BSplineFunction[dat]
Generate the surface, making sure to include (only) the boundary line, which will follow the edge of the surface. Make sure to set Mesh to either All or None.
pic = ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1}, Mesh -> None,
AspectRatio -> Automatic, PlotPoints -> 10, Boxed -> False,
Axes -> False, BoundaryStyle -> Red]
Extract the points from the boundary line:
bound = First#Cases[Normal[pic], Line[pts_] :> pts, Infinity]
Find the "corners", based on your parameter space:
corners = Flatten[Table[fu[u, v], {u, 0, 1}, {v, 0, 1}], 1]
Find the edge points best corresponding to the corners, keeping in mind that ParametricPlot3D doesn't use the limits exactly, so we can't just use Position:
nf = Nearest[bound -> Automatic];
nf /# corners
Figure our which range of points on the boundary correspond to the areas you need to fill up. This step involved some manual inspection.
sets = {bound[[2 ;; 22]], bound[[22 ;; 52]], bound[[52 ;; 72]],
bound[[72 ;;]]}
Construct new polygons corresponding to the holes:
Graphics3D[Polygon[sets[[{1, 3}]]], Boxed -> False, BoxRatios -> 1]
Show[pic, Graphics3D[Polygon[sets[[{1, 3}]]]]]
Note that there is probably still a hole that can't be seen where the edge runs between the holes you mentioned, and I haven't tried to fill it in, but you should have enough information to do that if needed.
Your data set looks like this:
Graphics3D[Point#Flatten[dat, 1]]
It consists of 22 sections of 50 points.
Adding a mid-line in each end section (which is actually the end section flattened):
dat2 = Append[Prepend[dat,
Table[(dat[[1, i]] + dat[[1, -i]])/2, {i, Length[dat[[1]]]}]
],
Table[(dat[[-1, i]] + dat[[-1, -i]])/2, {i, Length[dat[[-1]]]}]
];
Graphics3D[{Point#Flatten[dat, 1], Red, Point#dat2[[1]], Green, Point#dat2[[-1]]}]
Now add some weights to the wingtip rim:
sw = Table[1, {24}, {50}];
sw[[2]] = 1000 sw[[1]];
sw[[-2]] = 1000 sw[[1]];
fu = BSplineFunction[dat2, SplineWeights -> sw];
Show[
ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1}, Mesh -> All,
AspectRatio -> Automatic, PlotPoints -> 20, Boxed -> False,
Axes -> False, Lighting -> "Neutral"
],
Graphics3D[{PointSize -> 0.025, Green, Point#dat2[[-1]], Red,Point#dat2[[-2]]}]
]
Note that I increased the PlotPoints value to 20.
(*With your points in "dat"*)
fu = BSplineFunction[dat[[1 ;; 2]]];
Show[{ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1},
Mesh -> All, AspectRatio -> Automatic, PlotPoints -> 30],
ListPlot3D[dat[[1]]]}]
And with
InputForm[%]
you get the "unified" graphics object.
Edit
Another way, probably better:
(*With your points in "dat"*)
fu = BSplineFunction[dat];
Show[
{ ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1},
Mesh -> All, AspectRatio -> Automatic,
PlotPoints -> 10, Boxed -> False, Axes -> False],
ParametricPlot3D[
BSplineFunction[{First#dat, Reverse#First#dat}][u, v], {u, 0, 1}, {v, 0, 1},
Mesh -> None, PlotStyle -> Yellow],
ParametricPlot3D[
BSplineFunction[{dat[[First#Dimensions#dat]],
Reverse#dat[[First#Dimensions#dat]]}]
[u, v], {u, 0, 1}, {v, 0, 1}]}]
In just one structure:
(*With your points in "dat"*)
fd = First#Dimensions#dat;
ParametricPlot3D[
{BSplineFunction[dat][u, v],
BSplineFunction[{dat[[1]], Reverse#dat[[1]]}] [u, v],
BSplineFunction[{dat[[fd]], Reverse#dat[[fd]]}][u, v]},
{u, 0, 1}, {v, 0, 1},
Mesh -> All, AspectRatio -> Automatic,
PlotPoints -> 10, Boxed -> False, Axes -> False]
Edit
You can check that there are small triangles, but they are triangles indeed and not zero area polygons:
fu = BSplineFunction[dat];
check = ParametricPlot3D[{BSplineFunction[{First#dat, Reverse#dat[[1]]}][u, v]},
{u, 0, 1}, {v, 0, 1}, Mesh -> All,
PlotStyle -> Yellow, Mesh -> All, AspectRatio -> Automatic,
PlotPoints -> 10, Boxed -> False, Axes -> False];
pts = check /. Graphics3D[GraphicsComplex[a_, b__], ___] -> a;
m = check[[1]][[2]][[1]][[1]] /. {___, GraphicsGroup[{Polygon[a_]}]} -> a;
t = Replace[m, {a_, b_, c_} -> {pts[[a]], pts[[b]], pts[[c]]}, {1}];
polygonArea[pts_List?(Length[#] == 3 &)] :=
Norm[Cross[pts[[2]] - pts[[1]], pts[[3]] - pts[[1]]]]/2;
t[[Position[Ordering[polygonArea /# t], 1][[1]]]]
(*
->{{{-4.93236, 0.0989696, -2.91748},
{-4.92674, 0.0990546, -2.91748},
{-4.93456, 0.100181, -2.91748}}}
*)
I've just started using LevelScheme, and have issues with getting the histogram to fit correctly within the figure. A minimal non-working example:
<<"LevelScheme`"
Figure[{FigurePanel[{{0, 1}, {0, 1}},
LabB -> textit["x"], BufferB -> 2.5,
LabL -> textit["p(x)"], BufferL -> 2.5,
FrameTicks -> {LinTicks[-4, 4], LinTicks[0, 1]},
PlotRange -> {{-3, 3}, {0, 0.5}}],
RawGraphics[
Histogram[RandomReal[NormalDistribution[], 1000], Automatic,
"ProbabilityDensity"]]},
Frame -> False, PlotRange -> {{-0.075, 1.1}, {-0.1, 1.03}}]
The output looks like this
when it should look like this
Basically, the Histogram graphics object doesn't obey the FigurePanel's PlotRange, but instead obeys the main Figure's PlotRange. This behaviour doesn't occur when the Histogram is replaced by a Plot or similar commands. So the following produces a clean plot
Figure[{FigurePanel[{{0, 1}, {0, 1}},
LabB -> textit["x"], BufferB -> 2.5,
LabL -> textit["p(x)"], BufferL -> 2.5,
FrameTicks -> {LinTicks[-4, 4], LinTicks[0, 1]},
PlotRange -> {{-3, 3}, {0, 0.5}}],
RawGraphics[Plot[1/Sqrt[2 Pi] Exp[-x^2/2], {x, -4, 4}]]},
Frame -> False, PlotRange -> {{-0.075, 1.1}, {-0.1, 1.03}}]
Has anyone else encountered this issue? Or, do you have suggestions for a fix?
EDIT
I thought I'd add some green to the question. I'm still interested in knowing how to overcome this hurdle.
Well, I recon you won't like this one too much but it is a workaround of sorts.
If I give PerformanceGoal -> "Speed" as a Histogram option (rather than PerformanceGoal -> "Quality") I disable interactive behaviour but, with a few minor tweaks, I get the following:
<< "LevelScheme`"
Figure[{FigurePanel[{{0, 1}, {0, 1}}, LabB -> textit["x"],
BufferB -> 2.5, LabL -> textit["p(x)"], BufferL -> 2.5,
FrameTicks -> {LinTicks[-4, 4], LinTicks[0, 1]},
PlotRange -> {{-3, 3}, {0, 0.55}}],
RawGraphics[
Histogram[RandomReal[NormalDistribution[], 1000], Automatic,
"ProbabilityDensity", PerformanceGoal -> "Speed"]]},
Frame -> False, PlotRange -> {{-0.075, 1.1}, {-0.15, 1.1}}]
As Simon mentioned in a comment, you can use LevelScheme's DataPlot to plot a histogram.
<< "LevelScheme`"
histData[x_] :=
Cases[x, RectangleBox[{bl_, _}, {br_, c_}] :> {{bl, br}, c},
Infinity];
hist = histData[
Histogram[RandomReal[NormalDistribution[], 1000], {-4, 4, 0.1},
"ProbabilityDensity"]];
bins = hist[[All, 1, 1]]; counts = hist[[All, 2]];
data = Table[{bins[[i]], counts[[i]]}, {i, 1, Length#counts}];
Figure[{FigurePanel[{{0, 1}, {0, 1}}, LabB -> textit["x"],
BufferB -> 2.5, LabL -> textit["p(x)"], BufferL -> 2.5,
FrameTicks -> {LinTicks[-4, 4], LinTicks[0, 1]},
PlotRange -> {{-3, 3}, {0, 0.5}}],
DataPlot[data,
DataLine -> {LineShape -> "Histogram", LineColor -> Darker#Blue},
DataSymbol -> {SymbolSize -> 0.00001}],
RawGraphics[
Plot[1/Sqrt[2 Pi] Exp[-x^2/2], {x, -4, 4},
PlotStyle -> {Red, Thick}]]
}, Frame -> False, PlotRange -> {{-0.075, 1.1}, {-0.1, 1.03}}]
However, I haven't managed to get filled histogram bars like that produced by Histogram or BarChart, if that was also what you had intended.
BTW, the function histData is similar to something I saw on a mathematica help forum long ago, and it went in my useful functions toolkit. I don't remember where I read that or when, to credit it. However, it is not all that of a magic function now to me, as it was back then.
I know what the problem is, but I don't have an immediate fix. The way LevelScheme works is that it transforms the Graphics objects so that they fit correctly. To do this, RawGraphics uses the legacy function TransformGraphics from LegacyPackages\Graphics\Graphics.m which is included in LegacyTransformGraphics.m in v. 3.51 of the LevelScheme packages. Looking at the FullForm of your Histogram, you can see that TransformGraphics knows nothing about dealing with the sort of objects produced. Mark Caprio is working on an update to LevelScheme over the next couple of months, so there may be a fix on the way. In the mean time, try using Rasterize before supply your histogram to RawGraphics, although it may not give you good results.
Edit:
Instead of using the legacy version of TransformGraphics, a more recent version might look like
TransformGraphics[
(g:(Graphics | Graphics3D))[prims__, opts:OptionsPattern[], transform_]:=
g[ GeometricTransformation[prims, transform], opts ]
Of course, the trick is now supplying a version of transform that GeometricTransformation can accept. Although, the legacy TransformGraphics, applies a function, its second argument, directly to the points found in g, so using the above code may work without any additional changes.
To try it, replace Needs["LevelScheme`LegacyTransformGraphics`"] with the above code in either LevelScheme.nb (and regenerate LevelScheme.m) or in LevelScheme.m directly. It may not work completely, as I don't see where the options are substituted, but it should be a start.