Related
I have a tree (expression) on which I want to gather only certain types of nodes - those that follow a certain pattern. I have a simplified example below:
A = {{{{},{0.3,0.3}},{0.2,0.2}},{0.1,0.1}};
TreeForm[A, PlotRangePadding->0]
Cases[A, {x_Real, y_Real}, Infinity]
The output:
Is this a good way to do it?
If instead of {x_, y_}, if I wanted to look for {{x1_, y1_}, {x2_, y_2}}, how can I exclude expressions like {x_, y_}, which also match?
Regards
EDIT (14/07/2011)
I have found that using a head other than List will greatly aid in finding such sub-expressions without collisions.
For example, reformulating the above:
A = {{{{}, pt[0.3, 0.3]}, pt[0.2, 0.2]}, pt[0.1, 0.1]};
List ### Cases[A, _pt, Infinity]
Output:
{{0.3,0.3},{0.2,0.2},{0.1,0.1}}
About the second part of your question, ie, selecting {{a,b},{c,d}}, how about
b = {{{{}, {0.3, 0.3}}, {0.2, 0.2}}, {{0.1, 0.1}, {0.3, 0.4}}};
TreeForm[b]
Cases[b, {{a_, b_}, {c_, d_}} /; (And ## NumericQ /# {a, b, c, d}), Infinity]
(so that they do not have to be Real but any Numeric will do)?
Here is an alternative to the form acl used, that I find more readable.
b = {{{{}, {0.3, 0.3}}, {0.2, 0.2}}, {{0.1, 0.1}, {0.3, 0.4}}};
With[{p = _?NumericQ}, Cases[b, {{p, p}, {p, p}}, -1] ]
I am trying to define a replacement rule with optional argument color_RGBColor which should be replaced with Sequence[] when it is absent in the original expression:
style[line_Line, ___,
color_RGBColor: Unevaluated#Sequence[], ___] :> {color, line}
When RGBColor is present in the original expression, the rule works:
style[Line[], RGBColor[{}]] /.
style[line_Line, ___,
color_RGBColor: Unevaluated#Sequence[], ___] :> {color, line}
=> {RGBColor[{}], Line[]}
But when it is absent, it does not:
style[Line[], Thickness[0.01]] /.
Style[line_Line, ___,
color_RGBColor: Unevaluated#Sequence[], ___] :> {color, line}
=> style[Line[], Thickness[0.01]]
My questions are:
1) Why it does not work?
2) Is it possible to construct a single pattern which will work as desired?
Your pattern does not work because of the way the pattern-matching works for the default (optional) arguments, and also because you restricted the head to be RGBColor. The problem is that the default argument value must match the pattern, while Unevaluated[Sequence[]] certainly does not match _RGBColor.
You have several ways out. A first attempt is to weaken your type-checking:
In[10]:= style[Line[],Thickness[0.01]]/.
style[line_Line,___,color_: Unevaluated#Sequence[],___]:>{color,line}
Out[10]= {Thickness[0.01],Line[]}
But this does not work since the matching is incorrect - the typing is indeed too weak. The hacky way to make it work is this:
In[14]:= style[Line[], RGBColor[{}]] /.
style[line_Line, ___, color : (_RGBColor | _Unevaluated) :
Unevaluated#Sequence[], ___] :> {Evaluate#color, line}
Out[14]= {RGBColor[{}], Line[]}
In[15]:= style[Line[], Thickness[0.01]] /.
style[line_Line, ___, color : (_RGBColor | _Unevaluated) :
Unevaluated#Sequence[], ___] :> {Evaluate#color, line}
Out[15]= {Line[]}
The recommended way to do it is this:
In[18]:= style[Line[], Thickness[0.01]] /.
style[line_Line, ___, color : (_RGBColor | Automatic) : Automatic, ___] :>
If[color === Automatic, {line}, {color, line}]
Out[18]= {Line[]}
In[17]:= style[Line[], RGBColor[{}]] /.
style[line_Line, ___, color : (_RGBColor | Automatic) : Automatic, ___] :>
If[color === Automatic, {line}, {color, line}]
Out[17]= {RGBColor[{}], Line[]}
This feature of the pattern-matcher is not very widely known, so I will stress it again: the default value for the (optional) pattern x:ptrn:default must match ptrn. For another example of such behavior, see this Mathgroup discussion.
Perhaps this works for you:
style[Line[a], RGBColor[{}]] /.
style[line_Line, ___, Longest[color___RGBColor], ___] :> {color,line}
(*
{RGBColor[{}], Line[a]}
*)
style[Line[]] /.
style[line_Line, ___, Longest[color___RGBColor], ___] :> {color, line}
(*
{Line[]}
*)
I guess your replacement rule does not work just because there is no element with a Head RGBColor, so there is no match.
What is the simplest way to make an analog of MakeBoxes which will reproduce only on aspect of its behavior: converting correct expressions involving only symbols without FormatValues to BoxForms:
Trace[MakeBoxes[graphics[disk[]], StandardForm], TraceInternal -> True]
This function should be recursive as MakeBoxes is. What is really confusing is how to convert disk[] to RowBox[{"disk", "[", "]"}] avoiding parsing of string representation of the original expression.
P.S. This question comes from the previous question.
I don't think you can avoid parsing or string conversion in one way or another - at the end you need strings, and you start with symbols. Either you somehow reuse MakeBoxes, or you have to deal with strings. Dragging my code around: the following simple box-making function is based on the Mathematica parser posted here (my second post there, at the bottom of the page):
Clear[toBoxes];
toBoxes[expr_] :=
First[parse[tokenize[ToString#FullForm[expr]]] //. {
head_String[elem_] :> RowBox[{head, "[", elem, "]"}],
head_String[elems___] :> RowBox[{head, "[", RowBox[Riffle[{elems}, ","]], "]"}]}]
If you don't want to parse but don't mind ToString, then a slight variation of the above will do:
toBoxesAlt[expr_] :=
expr /. s_Symbol :> ToString[s] //. {
head_String[elem_] :> RowBox[{head, "[", elem, "]"}],
head_String[elems___] :> RowBox[{head, "[", RowBox[Riffle[{elems}, ","]], "]"}]}
Note that this last function does not involve any parsing.Then, we need:
Clear[MakeBoxesStopAlt];
MakeBoxesStopAlt /: MakeBoxes[MakeBoxesStopAlt[expr_], form_] := toBoxes[expr]
For example:
In[327]:= MakeBoxesStopAlt[Graphics[Disk[]]]
Out[327]= Graphics[Disk[List[0, 0]]]
You may want to re-implement the parser if my implementation looks too complicated, although mine is rather efficient.
EDIT
Here is a very simplistic and probably slow approach to parsing: the function tokenize is the same as before, and I will repost it here for convenience:
tokenize[code_String] :=
Module[{n = 0, tokenrules},
tokenrules = {"[" :> {"Open", ++n}, "]" :> {"Close", n--},
Whitespace | "" ~~ "," ~~ Whitespace | ""};
DeleteCases[StringSplit[code, tokenrules], "", Infinity]];
Here is the parsing function:
parseSimple[tokenized_] :=
First[tokenized //. {left___,
Shortest[
PatternSequence[h_, {"Open", n_}, elems___, {"Close", n_}]], right___} :>
{left, h[elems], right}];
You may use it in place of parse, and these two functions then form a self-contained solution for the parser.
The same comment as for my answer to your previous question is in order: if you want to handle /disallow expression evaluation, add appropriate attributes and Unevaluated wrappers where needed.
EDIT2
Here is a version of makeBoxes that does not involve parsing, does not leak evaluation and does handle nested heads correctly (at least for some simple tests):
Clear[handleElems];
handleElems[] := Sequence[];
handleElems[el_] := el;
handleElems[els__] := RowBox[Riffle[{els}, ","]];
ClearAll[makeBoxes];
SetAttributes[makeBoxes, HoldAllComplete];
makeBoxes[ex_] :=
Block[{makeBoxes},
SetAttributes[makeBoxes, HoldAllComplete];
makeBoxes[expr_ /;!FreeQ[Unevaluated[expr],
s_ /; AtomQ[Unevaluated[s]] && ! StringQ[Unevaluated[s]]]] :=
makeBoxes[#] &#(Unevaluated[expr] /.
s_ /; AtomQ[Unevaluated[s] && ! StringQ[Unevaluated[s]]] :>
ToString[Unevaluated[s]]);
makeBoxes[a_ /; AtomQ[Unevaluated[a]]] := a;
makeBoxes[expr_] /; MatchQ[expr, h_String[___]] :=
expr //. {
(h : ("Rule" | "RuleDelayed"))[l_, r_] :>
RowBox[{l, h /. {
"Rule" -> "\[Rule]",
"RuleDelayed" -> "\[RuleDelayed]"
}, r}],
"List"[elems___] :> RowBox[{"{", handleElems[elems], "}"}],
head_String[elems___] :> RowBox[{head, "[", handleElems[elems], "]"}]
};
makeBoxes[expr_] :=
RowBox[{makeBoxes[#] &#Head[expr], "[",
handleElems ## (makeBoxes ### expr), "]"}];
makeBoxes ## (HoldComplete[ex] /. s_String :>
With[{eval = StringJoin["\"", s, "\""]}, eval /; True])
];
Example of use:
In[228]:= a=1;b=2;c = 3;
In[229]:= makeBoxes[a:>b]
Out[229]= RowBox[{a,:>,b}]
In[230]:= makeBoxes[a->b]
Out[230]= RowBox[{a,->,b}]
In[231]:= makeBoxes[{a,{b,c}}]
Out[231]= RowBox[{{,RowBox[{a,,,RowBox[{{,RowBox[{b,,,c}],}}]}],}}]
In[232]:= makeBoxes[a[b][c]]
Out[232]= RowBox[{RowBox[{a,[,b,]}],[,c,]}]
In[233]:= makeBoxes[a[b[e[],f[]],c[g[],h[]]][x,y]]
Out[233]= RowBox[{RowBox[{a,[,RowBox[{RowBox[{b,[,RowBox[{RowBox[{e,
[,]}],,,RowBox[{f,[,]}]}],]}],,,RowBox[{c,[,RowBox[{RowBox[{g,[,]}],,,
RowBox[{h,[,]}]}],]}]}],]}],[,RowBox[{x,,,y}],]}]
In all cases tested, the output is the same as that of MakeBoxes.
Here is my implementation of simplified MakeBoxes without conversion of the original expression to string:
ClearAll[SimpleMakeBoxes, SimpleMakeBoxesRules];
SetAttributes[SimpleMakeBoxes, HoldAll];
SimpleMakeBoxesRules = {h_Symbol[] :> RowBox[{ToString#h, "[", "]"}],
h_Symbol[expr_] :>
RowBox[{ToString#h, "[", Unevaluated[expr] /. SimpleMakeBoxesRules, "]"}],
h_Symbol[expr__] :>
RowBox[{ToString#h, "[",
RowBox[Riffle[
List ## Replace[Hold[expr],
x_ :> (Unevaluated[x] /. SimpleMakeBoxesRules), {1}], ","]], "]"}],
a:(_Real | _Integer | _String) :> ToString[FullForm#a]};
SimpleMakeBoxes[expr_] :=
Unevaluated[expr] /.
SimpleMakeBoxesRules //. {RowBox[{"List", "[", elems___, "]"}] :>
RowBox[{"{", elems, "}"}],
RowBox[{"Rule", "[", RowBox[{lhs_, ",", rhs_}], "]"}] :>
RowBox[{lhs, "\[Rule]", rhs}],
RowBox[{"RuleDelayed", "[", RowBox[{lhs_, ",", rhs_}], "]"}] :>
RowBox[{lhs, "\[RuleDelayed]", rhs}]}
Usage example:
In[7]:= SimpleMakeBoxes#Graphics[Disk[]]
RawBoxes#%
Out[7]= RowBox[{Graphics,[,RowBox[{Disk,[,]}],]}]
Out[8]= Graphics[Disk[]]
I'm stuck on a conversion.
I have a KMZ file with some coordinates. I read the file like this:
m=Import["~/Desktop/locations.kmz","Data"]
I get something like this:
{{LayerName->Point Features,
Geometry->{
Point[{-120.934,49.3321,372}],
Point[{-120.935,49.3275,375}],
Point[{-120.935,49.323,371}]},
Labels->{},LabeledData->{},ExtendedData->{},
PlacemarkNames->{1,2,3},
Overlays->{},NetworkLinks->{}
}}
I want to extract the {x,y,z} from each of the points and also the placemark names {1,2,3} associated with the points. Even if I can just get the points out of Geometry->{} that would be fine because I can extract them into a list with List###, but I'm lost at the fundamental part where I can't extract the Geometry "Rule".
Thanks for any help,
Ron
While Leonid's answer is correct, you will likely find that it does not work with your code. The reason is that the output of your Import command contains strings, such as "LayerNames", rather than symbols, such as LayerNames. I've uploaded a KML file to my webspace so we can try this using an actual Import command. Try something like the following:
in = Import["http://facstaff.unca.edu/mcmcclur/my.kml", "Data"];
pointList = "Geometry" /.
Cases[in, Verbatim[Rule]["Geometry", _], Infinity];
pointList /. Point[stuff_] -> stuff
Again, note that "Geometry" is a string. In fact, the contents of in look like so (in InputForm):
{{"LayerName" -> "Waypoints",
"Geometry" -> {Point[{-82.5, 32.5, 0}]},
"Labels" -> {}, "LabeledData" -> {},
"ExtendedData" -> {}, "PlacemarkNames" -> {"asheville"},
"Overlays" -> {}, "NetworkLinks" -> {}}}
Context: KML refers to Keyhole Markup Language. Keyhole was a company that developed tools that ultimately became Google Earth, after they were acquired by Google. KMZ is a zipped version of KML.
A simplification to Leonid and Mark's answers that I believe can be made safely is to remove the fancy Verbatim construct. That is:
Leonid's first operation can be written:
Join ## Cases[expr, (Geometry -> x_) :> (x /. Point -> Sequence), Infinity]
Leonid's second operation:
Join ## Cases[expr, (PlacemarkNames -> x_) :> x, Infinity]
I had trouble importing Mark's data, but from what I can guess, one could write:
pointList = Cases[in, ("Geometry" -> x_) :> x, Infinity, 1]
I'll let the votes on this answer tell me if I am correct.
Given your expression
expr = {{LayerName -> Point Features,
Geometry -> {
Point[{-120.934, 49.3321, 372}],
Point[{-120.935, 49.3275, 375}],
Point[{-120.935, 49.323, 371}]},
Labels -> {}, LabeledData -> {}, ExtendedData -> {},
PlacemarkNames -> {1, 2, 3}, Overlays -> {}, NetworkLinks -> {}}}
This will extract the points:
In[121]:=
Flatten[Cases[expr, Verbatim[Rule][Geometry, x_] :> (x /. Point -> Sequence),
Infinity], 1]
Out[121]= {{-120.934, 49.3321, 372}, {-120.935, 49.3275,375}, {-120.935, 49.323, 371}}
And this will extract the placemarks:
In[124]:= Flatten[Cases[expr, Verbatim[Rule][PlacemarkNames, x_] :> x, Infinity], 1]
Out[124]= {1, 2, 3}
Here is a more elegant method exploiting that we are looking for rules, that will extract both:
In[127]:=
{Geometry, PlacemarkNames} /.Cases[expr, _Rule, Infinity] /. Point -> Sequence
Out[127]=
{{{-120.934, 49.3321, 372}, {-120.935, 49.3275,375}, {-120.935, 49.323, 371}}, {1, 2, 3}}
How about Transpose[{"PlacemarkNames", "Geometry"} /. m[[1]]] ?
I often wish to see the internal representation of Mathematica's graphical objects not in the FullForm but in much more readable InputForm having the ability to select parts of the code by double-clicking on it and easily copy this code to a new input Cell. But the default InputForm does not allow this since InputForm is displayed by default as a String, not as Mathematica's code. Is there a way to have InputForm displayed as Mathematica's code?
I also often wish to see a shortened version of such InputForm where all long lists of coordinates are displayed as the first coordinate followed by number of skipped coordinate values wrapped with Skeleton, all empty Lists removed and all numbers are also shortened for displaying no more than 6 digits. It would be even better to use 6 digits only for coordinates but for color directives such as Hue display only 2 significant digits. For example,
Plot[{Sin[x], .5 Sin[2 x]}, {x, 0, 2 \[Pi]},
Filling -> {1 -> {2}}] // ShortInputForm
should give:
Graphics[GraphicsComplex[{{1.28228`*^-7, 1.28228*^-7}, <<1133>>},
{{{EdgeForm[], Directive[{Opacity[0.2], Hue[0.67, 0.6, 0.6]}],
GraphicsGroup[{Polygon[{{1133, <<578>>}}]}]},
{EdgeForm[], Directive[{Opacity[0.2], Hue[0.67, 0.6, 0.6]}],
GraphicsGroup[{Polygon[{{432, <<556>>}}]}]}}, {{Hue[0.67, 0.6,
0.6], Line[{1, <<431>>}]}, {Hue[0.91, 0.6, 0.6],
Line[{432, <<701>>}]}}}], {AspectRatio -> GoldenRatio^(-1),
Axes -> True, AxesOrigin -> {0, 0},
Method -> {"AxesInFront" -> True},
PlotRange -> {{0, 2*Pi}, {-1., 1}},
PlotRangeClipping -> True,
PlotRangePadding -> {Scaled[0.02], Scaled[0.02]}}]
(note that -0.9999998592131705 is converted to -1., 1.2822827157509358*^-7 is converted to 1.28228*^-7 and Hue[0.9060679774997897, 0.6, 0.6] is converted to Hue[0.91, 0.6, 0.6]).
In this way, I wish to have the output of InputForm as Mathematica's code and also have a ShortInputForm function which will give the shortened version of this code. Can anybody help me?
As to the first part of the question, I have found one way to achieve what I want:
Plot[{Sin[x], .5 Sin[2 x]}, {x, 0, 2 \[Pi]}, Filling -> {1 -> {2}}] //
InputForm // StandardForm
UPDATE
The most recent version of the shortInputForm function can be found here.
Original post
Here is another, even better solution (compatible with Mathematica 5):
myInputForm[expr_] :=
Block[{oldContexts, output, interpretation, skeleton},
output = ToString[expr, InputForm];
oldContexts = {$Context, $ContextPath};
$Context = "myTemp`"; $ContextPath = {$Context};
output = DisplayForm#ToBoxes[ToExpression[output] /.
{myTemp`interpretation -> If[$VersionNumber >= 6,
System`Interpretation, System`First#{#} &],
myTemp`Row -> System`Row,
myTemp`skeleton -> System`Skeleton,
myTemp`sequence :> (System`Sequence ## # &)}, StandardForm];
{$Context, $ContextPath} = oldContexts; output]
shortInputForm[expr_] := myInputForm[expr /. {{} -> Sequence[],
lst : {x_ /; VectorQ[x, NumberQ], y__} /;
(MatrixQ[lst, NumberQ] && Length[lst] > 3) :>
{x /. v : {a_, b__} /; Length[v] > 3 :>
{a, interpretation[skeleton[Length[{b}]], sequence#{b}]},
interpretation[skeleton[Length[{y}]], sequence#{y}]},
lst : {x_, y__} /; VectorQ[lst, NumberQ] && Length[lst] > 3 :>
{x, interpretation[skeleton[Length[{y}]], sequence#{y}]}}]
How it works
This solution is based on simple idea: we need to block conversion of such things as Graphics, Point and others to typeset expressions in order to get them displayed in the internal form (as expressions suitable for input). Happily, if we do this, the resulting StandardForm output is found to be just formatted (two-dimensional) InputForm of the original expression. This is just what is needed!
But how to do this?
First of all, this conversion is made by FormatValues defined for Symbols like Graphics, Point etc. One can get full list of such Symbols by evaluating the following:
list = Symbol /#
Select[DeleteCases[Names["*"], "I" | "Infinity"],
ToExpression[#, InputForm,
Function[symbol, Length[FormatValues#symbol] > 0, HoldAll]] &]
My first idea was just Block all these Symbols (and it works!):
myInputForm[expr_] :=
With[{list = list}, Block[list, RawBoxes#MakeBoxes#expr]]
But this method leads to the evaluation of all these Symbols and also evaluates all FormatValues for all Symbols in the $ContextPath. I think it should be avoided.
Other way to block these FormatValues is just to remove context "System`" from the $ContextPath. But it works only if these Symbols are not resolved yet to the "System`" context. So we need first to convert our expression to String, then remove "System`" context from the $ContextPath and finally convert the string backward to the original expression. Then all new Symbols will be associated with the current $Context (and Graphics, Point etc. - too, since they are not in the $ContextPath). For preventing context shadowing conflicts and littering the "Global`" context I switch $Context to "myTemp`" which can be easily cleared if necessary.
This is how myInputForm works.
Now about shortInputForm. The idea is not just to display a shortened version of myInputForm but also preserve the ability to select and copy parts of the shortened code into new input cell and use this code as it would be the full code without abbreviations. In version 6 and higher it is possible to achieve the latter with Interpretation. For compatibility with pre-6 versions of Mathematica I have added a piece of code that removes this ability if $VersionNumber is less than 6.
The only problem that I faced when working with Interpretation is that it has no SequenceHold attribute and so we cannot simply specify Sequence as the second argument for Interpretation. But this problem can easily be avoided by wrapping sequence in List and then Applying Sequence to it:
System`Sequence ## # &
Note that I need to specify the exact context for all built-in Symbols I use because at the moment of calling them the "System`" context is not in the $ContextPath.
This ends the non-standard decisions taken me in the development of these functions. Suggestions and comments are welcome!
At this moment I have come to the following solution:
round[x_, n_] := (10^-n*Round[10^n*MantissaExponent[x]]) /.
{m_, e_} :> N[m*10^e];
ShortInputForm[expr_] := ((expr /.
{{} -> Sequence[],
lst : {x_ /; VectorQ[x, NumberQ], y__} /;
(MatrixQ[lst, NumberQ] && Length[lst] > 2) :>
{x, Skeleton[Length[{y}]]},
lst : {x_, y__} /; VectorQ[lst, NumberQ] && Length[lst] > 2 :>
{x, Skeleton[Length[{y}]]}} /.
{exp : Except[List | Point][x__] /;
VectorQ[{x}, MachineNumberQ] :>
(round[#, 2] & /# exp),
x_Real /; MachineNumberQ[x] :> round[x, 6]})
// InputForm // StandardForm)
Now: