Related
How can one extract the coordinates of all the points which make up the following graphics (here just an example)?
spl = BSplineCurve[{{-.4, -.3}, {0, -.6}, {.4, -.3}, {0, -1.2}},
SplineClosed -> True] ;
Graphics[{Red, Thick, spl}]
The problem is that if I add //FullForm to the last line there is no point coordinates in the output, so no pattern to use to make that extraction:
With a Plotor CoutourPlot output I would have coded Flatten[Cases[Normal#output, Line[x_] :> x, Infinity], 1]
which is not possible here.
The b-spline is itself a graphics primitive so you cant pull out the "line" like that.
You need to use the related BSplineFunction to generate your points:
pts=BSplineFunction[{{-.4, -.3}, {0, -.6}, {.4, -.3}, {0, -1.2}},
SplineClosed -> True] /# Range[0, 1, .01];
Graphics#Line#pts
If you need to extract from a graphic you can do this:
Cases[graphics, BSplineCurve[a__] :> BSplineFunction[a], Infinity]
but you still need to feed it a table of parameter values to get your points.
To extract just the control points you can go:
curveData=Cases[graphics, BSplineCurve[a__] :> a, Infinity]
how many BSplineCurves were found in the graphic?
Length[curveData]
here are the control points of one of them
curveData// First // MatrixForm
If you have a list of BSplineFunctions you can find out much more
so first convert the BSplineCurves to BSplineFunctions as the previous post
bfs =Cases[graphics, BSplineCurve[a__] :> BSplineFunction[a], Infinity]
then you could just go
Inputform[bfs]
and parse the result, but it is cleaner to go:
cdata = Cases[bfs, BSplineFunction[a__] :> a, Infinity];
d = Partition[cdata, 9];
This is Mathematica 11. other versions may need different partitioning
each element of d will be something like:
d[[1]] // MatrixForm
1
{{0.,1.}}
{3}
{False}
{{{0.,0.,0.},{0.,298.986,167.077},{0.,497.083,497.459},{0.,503.603,839.898}},Automatic}
{{0.,0.,0.,0.,1.,1.,1.,1.}}
{0}
MachinePrecision
Unevaluated
The 5th element contains the control point coordinates. The sixth corresponds to the knots. The other elements look familiar but let us not post our guesses!
I'm trying to write a short piece of code that will perform propagation of errors. So far, I can get Mathematica to generate the formula for the error delta_f in a function f(x1,x2,...,xi,...,xn) with errors dx1,dx2,...,dxi,...dxn:
fError[f_, xi__, dxi__] :=
Sum[(D[f[xi], xi[[i]]]*dxi[[i]])^2, {i, 1, Length[xi]}]^(1/2)
where fError requires that the input function f has all of its variables surrounded by {...}. For example,
d[{mv_, Mv_, Av_}] := 10^(1/5 (mv - Mv + 5 - Av))
FullSimplify[fError[d, {mv, Mv, Av}, {dmv, dMv, dAv}]]
returns
2 Sqrt[10^(-(2/5) (Av - mv + Mv)) (dAv^2 + dmv^2 + dMv^2)] Log[10]
My question is, how can I evaluate this? Ideally I would like to modify fError to something like:
fError[f_, xi__, nxi__, dxi__]
where nxi is the list of actual values of xi (separated since setting the xi's to their numerical values will destroy the differentiation step above.) This function should find the general formula for the error delta_f and then evaluate it numerically, if possible. I think the solution should be as simple as a Hold[] or With[] or something like that, but I can't seem to get it.
I'm not following everything that you've done, and since this was posted two years ago it's likely you aren't working on it anymore anyways. I'll give you my solution for error propagation in hopes that it will somehow help you or others.
I tried to include the best documentation that I could in the video and files linked below. If you open the .cdf file and weed through it you should be able to see my code...
Files:
https://drive.google.com/file/d/0BzKVw6gFYxk_YUk4a25ZRFpKaU0/view?pli=1
Video Tutorial:
https://www.youtube.com/watch?v=q1aM_oSIN7w
-Brian
Edit:
I posted the links because I couldn't attach files and didn't want to post code with no documentation for people new to mathematica. Here's the code directly. I would encourage anyone finding this solution helpful to take a quick look at the documentation because it demonstrates some tricks to improve productivity.
Manipulate[
varlist = ToExpression[variables];
funct = ToExpression[function];
errorFunction[variables, function]
, {variables, "{M,m}"}, {function, "g*(M-m)/(M+m)"},
DisplayAllSteps -> True, LabelStyle -> {FontSize -> 17},
AutoAction -> False,
Initialization :> (
errorFunction[v_, f_] := (
varlist = ToExpression[v];
funct = ToExpression[f];
varlength = Length[Variables[varlist]];
theoretical =
Sqrt[(Total[
Table[(D[funct, Part[varlist, n]]*
Subscript[U, Part[varlist, n]])^2, {n, 1,
varlength}]])];
Part[theoretical, 1];
varlist;
uncert = Table[Subscript[U, Part[varlist, n]], {n, 1, varlength}];
uncert = DeleteCases[uncert, Alternatives ## {0}];
theoretical = Simplify[theoretical];
Column[{Row[{Grid[{
{"Variables", varlist},
{"Uncertainties", uncert},
{"Function", function},
{"Uncertainty Function", theoretical}}, Alignment -> Left,
Spacings -> {2, 1}, Frame -> All,
ItemStyle -> {"Text", FontSize -> 20},
Background -> {{LightGray, None}}]}],
Row[{
Grid[{{"Brian Gennow March/24/2015"}}, Alignment -> Left,
Spacings -> {2, 1}, ItemStyle -> "Text",
Background -> {{None}}]
}]}]))]
This question was posted over 5 years ago, but I ran into the same issue recently and thought I'd share my solution (for uncorrelated errors).
I define a function errorProp that takes two arguments, func and vars. The first argument of errorProp, func, is the symbolic form of the expression for which you wish to calculate the error of its value due to the errors of its arguments. The second argument for errorProp should be a list of the form
{{x1,x1 value, dx1, dx1 value},{x2,x2 value, dx2, dx2 value}, ... ,
{xn,xn value, dxn, dxn value}}
Where the xi's and dxi's are the symbolic representations of the variables and their errors, while the xi value and dxi value are the numerical values of the variable and its uncertainty (see below for an example).
The function errorProp returns the symbolic form of the error, the value of the input function func, and the value of the error of func calculated from the inputs in vars. Here is the code:
ClearAll[errorProp];
errorProp[func_, vars_] := Module[{derivs=Table[0,{Length[vars]}],
funcErrorForm,funcEval,funcErrorEval,rplcVals,rplcErrors},
For[ii = 1, ii <= Length[vars], ii++,
derivs[[ii]] = D[func, vars[[ii, 1]]];
];
funcErrorForm = Sqrt[Sum[(derivs[[ii]]*vars[[ii, 3]])^2,{ii,Length[vars]}]];
SetAttributes[rplcVals, Listable];
rplcVals = Table[Evaluate[vars[[ii, 1]]] :> Evaluate[vars[[ii, 2]]], {ii,
Length[vars]}];
SetAttributes[rplcErrors, Listable];
rplcErrors = Table[Evaluate[vars[[ii, 3]]] :> Evaluate[vars[[ii, 4]]], {ii,
Length[vars]}];
funcEval = func /. rplcVals;
funcErrorEval = funcErrorForm /. rplcVals /. rplcErrors;
Return[{funcErrorForm, funcEval, funcErrorEval}];
];
Here I show an example of errorProp in action with a reasonably complicated function of two variables:
ClearAll[test];
test = Exp[Sqrt[1/y] - x/y];
errorProp[test, {{x, 0.3, dx, 0.005}, {y, 0.9, dy, 0.1}}]
returns
{Sqrt[dy^2 E^(2 Sqrt[1/y] - (2 x)/y) (-(1/2) (1/y)^(3/2) + x/y^2)^2 + (
dx^2 E^(2 Sqrt[1/y] - (2 x)/y))/y^2], 2.05599, 0.0457029}
Calculating using the error propagation formula returns the same result:
{Sqrt[(D[test, x]*dx)^2 + (D[test, y]*dy)^2],
test /. {x :> 0.3, dx :> 0.005, y :> 0.9, dy :> 0.1},
Sqrt[(D[test, x]*dx)^2 + (D[test, y]*dy)^2] /. {x :> 0.3,
dx :> 0.005, y :> 0.9, dy :> 0.1}}
returns
{Sqrt[dy^2 E^(
2 Sqrt[1/y] - (2 x)/y) (-(1/2) (1/y)^(3/2) + x/y^2)^2 + (
dx^2 E^(2 Sqrt[1/y] - (2 x)/y))/y^2], 2.05599, 0.0457029}
Mathematica 12 introduced the Around function that handles error propagation using the differential method.
So although not quite in the format required in the question, but something like this is possible:
expression = a^2*b;
expression /. {a -> Around[aval, da], b -> Around[bval, db]}
output:
aval^2 bval ± Sqrt[aval^4 db^2+4 bval^2 Abs[aval da]^2]
Instead of aval, bval, da, db you can use numerical values as well.
I am using NDSolve[] to integrate an orbital trajectory (with ExplicitRungeKutta). Mathematica gives me
{{x[t]->InterpolatingFunction[{{0.,2000.}},<>][t],
y[t]->InterpolatingFunction[{{0.,2000.}},<>][t]}}
My question is how do I get this into table of raw data where t=0,1,2...2000?
I tried:
path = Table[Solved, {t, 0, tmax}];
But I get a huge table of stuff like this:
{{{x[0] -> -0.523998, y[0] -> 0.866025}}, {{x[1] -> -0.522714,
y[1] -> 0.886848}}, {{x[2] -> -0.480023,
y[2] -> 0.951249}}, {{x[3] -> -0.369611, y[3] -> 1.02642}}
I want something like:
{{{-0.523998, 0.866025}}, {{-0.522714, 0.886848}}, etc
I don't have a lot of experience working with these Interpolating functions, any help would be appreciated.
You are getting back rules, not functions directly. In order to access the interpolating functions themselves, you need to do a rule replacement.
Instead of
Table[Solved, {t, 0, tmax}]
you need
Table[Evaluate[{x[t], y[t]} /. Solved], {t, 0, tmax}];
Solved (which I assume is the output of NDSolve) is just a list of rules which will allow for the expressions x[t] and y[t] to be replaced by the corresponding interpolating functions, which you then evaluate.
Check out the F1 help for NDSolve for more examples.
You could try using the PropertyValue[] function if you are interested in the points that were used to interpolate - which sometimes is interesing when using NDSolve[]. See the example below:
x = Range[1, 10];
y = x^2;
pts = Transpose[{x, y}];
f = Interpolation[pts];
Plot[f[t], {t, 1, 10}]
(*getting the coordinates*)
X = PropertyValue[f, "Coordinates"][[1]]
Y = PropertyValue[f, "ValuesOnGrid"]
ListPlot[Transpose[{X, Y}]]
In such way you can extract almost any properties of any object. To get the list of properties use PropertyList[] function. In the above example it returns:
PropertyList[f]
{"Coordinates", "DerivativeOrder", "Domain", "ElementMesh",
"Evaluate", "GetPolynomial", "Grid", "InterpolationMethod",
"InterpolationOrder", "MethodInformation", "Methods",
"OutputDimensions", "Periodicity", "PlottableQ", "Properties",
"QuantityUnits", "Unpack", "ValuesOnGrid"}
I've been playing around with Mathematica's visualization and webcrawling capabilities. Building on some demonstration code, I'm able to visualize the a network. Here's an example on a university webpage:
webcrawler[rooturl_, depth_] :=
Flatten[Rest[NestList[
Union[Flatten[Thread[# -> Import[#,"Hyperlinks"]] & /# Last /# #]] &,
{"" -> rooturl}, depth]]];
Graph[webcrawler[
"http://www.yorku.ca/", 2], {ImageSize -> Full}]
However, I've been trying fruitlessly to figure out a way to apply EdgeLabels[] to this Graph[] command. I would like to have each link written on each line, just to give a sense of what exactly the link clusters represent.
I've tried applying a generated list of the Hyperlink connections to it, which didn't work, and neither did any of the readily obvious commands from documentation/elsewhere on stack/the cookbook.
I envision a very cluttered output.
I don't know in case of a large graph how will the edge label look. But here how it can be done in Mathematica 8.
webcrawler[rooturl_, depth_] :=
Flatten[Rest[
NestList[
Union[Flatten[
Thread[# -> Import[#, "Hyperlinks"]] & /#
Last /# #]] &, {"" -> rooturl}, depth]]];
dats = webcrawler["http://www.uni-kl.de/", 2];
Graph[dats ,EdgeLabels ->Table[dats[[i]] -> dats[[i]][[2]],
{i,Length[dats]}], {ImageSize -> Full}]
I hope this helps.
BR
Place EdgeLabels inside Tooltips
The following will display the names of both the edges and the vertices as tooltips. (You can remove the VertexLabels, of course. I included them because the EdgeLabels were often very long.)
data = webcrawler["http://www.yorku.ca/", 2];
Graph[data,
EdgeLabels -> Placed["Name", Tooltip],
EdgeShapeFunction -> "Line",
VertexLabels -> Placed["Name", Tooltip],
EdgeStyle -> {Orange},
VertexSize -> {"Scaled", 0.007},
ImageSize -> 800]
It should be helpful for browsing the network. But of course, it will not print out the labels.
Many algorithms (like the algorithm for finding the next permutation of a list in lexicographical order) involve finding the index of the last element in a list. However, I haven't been able to find a way to do this in Mathematica that isn't awkward. The most straightforward approach uses LengthWhile, but it means reversing the whole list, which is likely to be inefficient in cases where you know the element you want is near the end of the list and reversing the sense of the predicate:
findLastLengthWhile[list_, predicate_] :=
(Length#list - LengthWhile[Reverse#list, ! predicate## &]) /. (0 -> $Failed)
We could do an explicit, imperative loop with Do, but that winds up being a bit clunky, too. It would help if Return would actually return from a function instead of the Do block, but it doesn't, so you might as well use Break:
findLastDo[list_, pred_] :=
Module[{k, result = $Failed},
Do[
If[pred#list[[k]], result = k; Break[]],
{k, Length#list, 1, -1}];
result]
Ultimately, I decided to iterate using tail-recursion, which means early termination is a little easier. Using the weird but useful #0 notation that lets anonymous functions call themselves, this becomes:
findLastRecursive[list_, pred_] :=
With[{
step =
Which[
#1 == 0, $Failed,
pred#list[[#1]], #1,
True, #0[#1 - 1]] &},
step[Length#list]]
All of this seems too hard, though. Does anyone see a better way?
EDIT to add: Of course, my preferred solution has a bug which means it's broken on long lists because of $IterationLimit.
In[107]:= findLastRecursive[Range[10000], # > 10000 &]
$IterationLimit::itlim: Iteration limit of 4096 exceeded.
Out[107]= (* gack omitted *)
You can fix this with Block:
findLastRecursive[list_, pred_] :=
Block[{$IterationLimit = Infinity},
With[{
step =
Which[
#1 == 0, $Failed,
pred#list[[#1]], #1,
True, #0[#1 - 1]] &},
step[Length#list]]]
$IterationLimit is not my favorite Mathematica feature.
Not really an answer, just a couple of variants on findLastDo.
(1) Actually Return can take an undocumented second argument telling what to return from.
In[74]:= findLastDo2[list_, pred_] :=
Module[{k, result = $Failed},
Do[If[pred#list[[k]], Return[k, Module]], {k, Length#list, 1, -1}];
result]
In[75]:= findLastDo2[Range[25], # <= 22 &]
Out[75]= 22
(2) Better is to use Catch[...Throw...]
In[76]:= findLastDo3[list_, pred_] :=
Catch[Module[{k, result = $Failed},
Do[If[pred#list[[k]], Throw[k]], {k, Length#list, 1, -1}];
result]]
In[77]:= findLastDo3[Range[25], # <= 22 &]
Out[77]= 22
Daniel Lichtblau
For the adventurous...
The following definitions define a wrapper expression reversed[...] that masquerades as a list object whose contents appear to be a reversed version of the wrapped list:
reversed[list_][[i_]] ^:= list[[-i]]
Take[reversed[list_], i_] ^:= Take[list, -i]
Length[reversed[list_]] ^:= Length[list]
Head[reversed[list_]] ^:= List
Sample use:
$list = Range[1000000];
Timing[LengthWhile[reversed[$list], # > 499500 &]]
(* {1.248, 500500} *)
Note that this method is slower than actually reversing the list...
Timing[LengthWhile[Reverse[$list], # > 499500 &]]
(* 0.468, 500500 *)
... but of course it uses much less memory.
I would not recommend this technique for general use as flaws in the masquerade can manifest themselves as subtle bugs. Consider: what other functions need to implemented to make the simulation perfect? The exhibited wrapper definitions are apparently good enough to fool LengthWhile and TakeWhile for simple cases, but other functions (particularly kernel built-ins) may not be so easily fooled. Overriding Head seems particularly fraught with peril.
Notwithstanding these drawbacks, this impersonation technique can sometimes be useful in controlled circumstances.
Personally, I don't see anything wrong with LengthWhile-based solution. Also, if we want to reuse mma built-in list-traversing functions (as opposed to explicit loops or recursion), I don't see a way to avoid reverting the list. Here is a version that does that, but does not reverse the predicate:
Clear[findLastLengthWhile];
findLastLengthWhile[{}, _] = 0;
findLastLengthWhile[list_, predicate_] /; predicate[Last[list]] := Length[list];
findLastLengthWhile[list_, predicate_] :=
Module[{l = Length[list]},
Scan[If[predicate[#], Return[], l--] &, Reverse[list]]; l];
Whether or not it is simpler I don't know. It is certainly less efficient than the one based on LengthWhile, particularly for packed arrays. Also, I use the convention of returning 0 when no element satisfying a condition is found, rather than $Failed, but this is just a personal preference.
EDIT
Here is a recursive version based on linked lists, which is somewhat more efficient:
ClearAll[linkedList, toLinkedList];
SetAttributes[linkedList, HoldAllComplete];
toLinkedList[data_List] := Fold[linkedList, linkedList[], data];
Clear[findLastRec];
findLastRec[list_, pred_] :=
Block[{$IterationLimit = Infinity},
Module[{ll = toLinkedList[list], findLR},
findLR[linkedList[]] := 0;
findLR[linkedList[_, el_?pred], n_] := n;
findLR[linkedList[ll_, _], n_] := findLR[ll, n - 1];
findLR[ll, Length[list]]]]
Some benchmarks:
In[48]:= findLastRecursive[Range[300000],#<9000&]//Timing
Out[48]= {0.734,8999}
In[49]:= findLastRec[Range[300000],#<9000&]//Timing
Out[49]= {0.547,8999}
EDIT 2
If your list can be made a packed array (of whatever dimensions), then you can exploit compilation to C for loop-based solutions. To avoid the compilation overhead, you can memoize the compiled function, like so:
Clear[findLastLW];
findLastLW[predicate_, signature_] := findLastLW[predicate, Verbatim[signature]] =
Block[{list},
With[{sig = List#Prepend[signature, list]},
Compile ## Hold[
sig,
Module[{k, result = 0},
Do[
If[predicate#list[[k]], result = k; Break[]],
{k, Length#list, 1, -1}
];
result],
CompilationTarget -> "C"]]]
The Verbatim part is necessary since in typical signatures like {_Integer,1}, _Integer will otherwise be interpreted as a pattern and the memoized definition won't match. Here is an example:
In[60]:=
fn = findLastLW[#<9000&,{_Integer,1}];
fn[Range[300000]]//Timing
Out[61]= {0.016,8999}
EDIT 3
Here is a much more compact and faster version of recursive solution based on linked lists:
Clear[findLastRecAlt];
findLastRecAlt[{}, _] = 0;
findLastRecAlt[list_, pred_] :=
Module[{lls, tag},
Block[{$IterationLimit = Infinity, linkedList},
SetAttributes[linkedList, HoldAllComplete];
lls = Fold[linkedList, linkedList[], list];
ll : linkedList[_, el_?pred] := Throw[Depth[Unevaluated[ll]] - 2, tag];
linkedList[ll_, _] := ll;
Catch[lls, tag]/. linkedList[] :> 0]]
It is as fast as versions based on Do - loops, and twice faster than the original findLastRecursive (the relevant benchmark to be added soon - I can not do consistent (with previous) benchmarks being on a different machine at the moment). I think this is a good illustration of the fact that tail-recursive solutions in mma can be as efficient as procedural (uncompiled) ones.
Here are some alternatives, two of which don't reverse the list:
findLastLengthWhile2[list_, predicate_] :=
Length[list]-(Position[list//Reverse, _?(!predicate[#] &),1,1]/.{}->{{0}})[[1, 1]]+1
findLastLengthWhile3[list_, predicate_] :=
Module[{lw = 0},
Scan[If[predicate[#], lw++, lw = 0] &, list];
Length[list] - lw
]
findLastLengthWhile4[list_, predicate_] :=
Module[{a}, a = Split[list, predicate];
Length[list] - If[predicate[a[[-1, 1]]], Length[a[[-1]]], 0]
]
Some timings (number 1 is Pillsy's first one) of finding the last run of 1's in an array of 100,000 1's in which a single zero is placed on various positions. Timings are the mean of 10 repeated meusurements:
Code used for timings:
Monitor[
timings = Table[
ri = ConstantArray[1, {100000}];
ri[[daZero]] = 0;
t1 = (a1 = findLastLengthWhile[ri, # == 1 &];) // Timing // First;
t2 = (a2 = findLastLengthWhile2[ri, # == 1 &];) // Timing // First;
t3 = (a3 = findLastLengthWhile3[ri, # == 1 &];) // Timing // First;
t4 = (a4 = findLastLengthWhile4[ri, # == 1 &];) // Timing // First;
{t1, t2, t3, t4},
{daZero, {1000, 10000, 20000, 50000, 80000, 90000, 99000}}, {10}
], {daZero}
]
ListLinePlot[
Transpose[{{1000, 10000, 20000, 50000, 80000, 90000,99000}, #}] & /#
(Mean /# timings // Transpose),
Mesh -> All, Frame -> True, FrameLabel -> {"Zero position", "Time (s)", "", ""},
BaseStyle -> {FontFamily -> "Arial", FontWeight -> Bold,
FontSize -> 14}, ImageSize -> 500
]
Timing Reverse for Strings and Reals
a = DictionaryLookup[__];
b = RandomReal[1, 10^6];
Timing[Short#Reverse##] & /# {a, b}
(*
->
{{0.016, {Zyuganov,Zyrtec,zymurgy,zygotic,zygotes,...}},
{3.40006*10^-15,{0.693684,0.327367,<<999997>>,0.414146}}}
*)
An elegant solution would be:
findLastPatternMatching[{Longest[start___], f_, ___}, f_] := Length[{start}]+1
(* match this pattern if item not in list *)
findLastPatternMatching[_, _] := -1
but as it's based on pattern matching, it's way slower than the other solutions suggested.