Applying Orthogonalize[] once:
v1 = PolyhedronData["Dodecahedron", "VertexCoordinates"][[1]];
Graphics3D[Line[{{0, 0, 0}, #}] & /#
Orthogonalize[{a, b, c} /.
FindInstance[{a, b, c}.v1 == 0 && (Chop#a != 0.||Chop#b != 0.||Chop#c != 0.),
{a, b, c}, Reals, 4]], Boxed -> False]
And now twice:
Graphics3D[Line[{{0, 0, 0}, #}] & /#
Orthogonalize#Orthogonalize[{a, b, c} /.
FindInstance[{a, b, c}.v1 == 0 && (Chop#a != 0.||Chop#b != 0.||Chop#c != 0.),
{a, b, c}, Reals, 4]], Boxed -> False]
Errr ... Why?
I think the first result is due to numerical error, taking
sys = {a,b,c}/.FindInstance[
{a, b, c}.v1 == 0 && (Chop#a != 0. || Chop#b != 0. || Chop#c !=0.),
{a, b, c}, Reals, 4];
then MatrixRank#sys returns 2, therefor the system itself is only two dimensional. To me, this implies that the first instance of Orthogonalize is generating a numerical error, and the second instance is using the out of plane error to give you your three vectors. Removing the Chop conditions fixes this,
Orthogonalize[{a, b, c} /.
N#FindInstance[{a, b, c}.v1 == 0,{a, b, c}, Reals, 4]]
where N is necessary to get rid of the Root terms that appear. This gives you a two-dimensional system, but you can get a third by taking the cross product.
Edit: Here's further evidence that its numerical error due to Chop.
With Chop, FindInstance gives me
{{64., 3.6, 335.108}, {-67., -4.3, -350.817}, {0, 176., 0},
{-2., -4.3, -10.4721}}
Without Chop, I get
{{-16.8, 3.9, -87.9659}, {6.6, -1.7, 34.558}, {13.4, -4.3, 70.1633},
{19.9, -4.3, 104.198}}
which is a significant difference between the two.
I also assumed it would be a numerical error, but didn't quite understand why, so I tried to implement Gram-Schmidt orthogonalization myself, hoping to understand the problem on the way:
(* projects onto a unit vector *)
proj[u_][v_] := (u.v) u
Clear[gm, gramSchmidt]
gm[finished_, {next_, rest___}] :=
With[{v = next - Plus ## Through[(proj /# finished)[next]]},
gm[Append[finished, Normalize#Chop[v]], {rest}]
]
gm[finished_, {}] := finished
gramSchmidt[vectors_] := gm[{}, vectors]
(Included for illustration only, I simply couldn't quite figure out what's going on before I reimplemented it myself.)
A critical step here, which I didn't realize before, is deciding whether a vector we get is zero or not before the normalization step (see Chop in my code). Otherwise we might get something tiny, possibly a mere numerical error, which is then normalized back into a large value.
This seems to be controlled by the Tolerance option of Orthogonalize, and indeed, raising the tolerance, and forcing it to discard tiny vectors fixes the problem you describe. Orthogonalize[ ... , Tolerance -> 1*^-10] works in a single step.
Perhaps it is a characteristic of the default GramSchmidt method?
Try: Method -> "Reorthogonalization" or Method -> "Householder".
Related
I`ve seen several answers for quite similar topics with usage of ?NumericQ explained and still can not quite understand what is wrong with my implementation and could my example be evaluated at all the way I want it.
I have solution of differential equation in form of ParametricNDSolve (I believe that exact form of equation is irrelevant):
sol = ParametricNDSolve[{n'[t] == g/(1/(y - f*y) + b*t + g*t)^2 - a*n[t] - c*n[t]^2, n[0] == y*f}, {n}, {t, 0, 10}, {a, b, c, g, f, y}]
After that I am trying to construct a function for FindFit or similar procedure, Nintegrating over function n[a,b,c,g,f,y,t] I have got above with some multiplier (I have chosen Log[z] as multiplier for simplicity)
Func[z_, a_, b_, c_, g_, f_] :=
NIntegrate[
Log[z]*(n[a, b, c, g, f, y][t] /. sol), {t, 0, 10}, {y, 0, Log[z]}]
So I have NIntegrate over my function n[params,t] derived from ParametricNDSolve with multiplier introducing new variable (z) wich also present in the limits of integration (in the same form as in multiplier for simplicity of example)
I am able to evaluate the values of my function Func at any point (z) with given values of parameters (a,b,c,g,f): Func(0,1,2,3,4,5) could be evaluated.
But for some reasons I cannot use FindFit like that:
FindFit[data, Func[z, a, b, c, g, f], {a, b, c, g, f}, z]
The error is: NIntegrate::nlim: y = Log[z] is not a valid limit of integration.
I`ve tried a lot of different combinations of ?NumericQ usage and all seems to lead nowhere. Any help would be appreciated!
Thanks in advance and sorry for pure english in the problem explanation.
Here is a way to define your function:
sol = n /.
ParametricNDSolve[{n'[t] ==
g/(1/(y - f*y) + b*t + g*t)^2 - a*n[t] - c*n[t]^2,
n[0] == y*f}, {n}, {t, 0, 10}, {a, b, c, g, f, y}]
Func[z_?NumericQ, a_?NumericQ, b_?NumericQ, c_?NumericQ, g_?NumericQ,
f_?NumericQ] :=
NIntegrate[Log[z]*sol[a, b, c, g, f, y][t],
{t, 0, 10}, {y, 0, Log[z]}]
test: Func[2, .45, .5, .13, .12, .2] -> 0.106107
I'm not optimistic you will get good results from FindFit with a function with so many parameters and which is so computationally expensive.
I'm a beginner in Mathematica programming. My code is not running as expected. I wonder if anyone could examine what goes wrong? Here is part of the code.
F[{k_, n_, x_}] =
Which[k == 0, f[a, b, x],
k == 1, g[a, b, n, x],
k == 2, h[c, d, n, x]]
G[x_] = F[{0, 0, x}]
While[Extract[G[x], 1] != 3, G[x_] = F[G[x]]]
The functions f, g and h are defined by Which as is F, and they are all vector-valued so that it makes sense to iterate F. What I want to achieve is: given initial value {0,0,x}, keep iterating F until the first component of F becomes 3. Is there anything, e.g. syntax, wrong in the above code?
Thanks!
You need to use SetDelayed (:=) for function definitions like: F[x_]:=x. When you use Set (=) like F[x_]=x, the it is essentially the same as F[_]=x since the definition isn't delayed until evaluation, so there is no way to transfer the matched pattern on the left hand side into the evaluation of the right hand side.
As jVincent mentioned, I would use := instead of = while defining F.
I would also use the built in NestWhile instead of manually iterating.
NestWhile[F, {0, 0, x}, Function[e, Extract[e, 1] != 3]]
I can't quite comment on how to correct the code as written because I'm not entirely sure how reassigning G in the While works.
Any easy question for the Mathematica experts here:
Given a list, say
Clear[a, b, c];
data = {a, b, c};
and I want to get back all lists of length 1,2,3,...Length[data] starting from the start to the end, so that I get the following for the above
out = {{a}, {a, b}, {a, b, c}}
I looked at the commands in M to find a ready one to use, and I could (looked at all the Map's and Nest* functions, but not that I can see how to use for this). I am sure it is there, but I am not seeing it now.
now I do this silly Do loop to build it
m=Length[data];
First#Reap[Do[Sow[data[[1;;i]]],{i,1,m}]][[2]]
{{a},{a,b},{a,b,c}}
question is: does Mathematica have a build-in command to do the above?
update 8 am
I've deleted the tests I've done an hr ago and will be reposting them again soon. I need to run them few times and take an average as that is the better way to do this performance test.
update 9 am
Ok, I've re-run the performance tests on all solutions shown below. 8 methods.
For each method, I run it 5 times and took the mean.
I did this for n={1000, 5000, 10000, 15000, 25000, 30000} where n is the length of the original list to process.
can't go much over 30,000, will run out of ram. I only have 4 GB ram.
I made a small function called makeTable[n, methods] which generate performance table for specific n. test code is below (written quickly so not the most clean code, not very functional, as I have to go :), but it is below and any one can change/clean it, etc... if they want
conclusion: Kguler method was the fastest, with Thies method almost the same for large n, (30,000), so for all practical purposes, may be Thies and Kguler methods can be declared as the winners for large n? But since Kguler is also fastest for small n, so far, he gets the clear edge.
Again, test code is below for any one to check and run to see if I might made an error somewhere. As correctly predicted by Leonid, the linked list method did not fare too well for large n.
I think more tests are needed, as only taking the mean of 5 might not be enough, also other considerations I might have missed. This is not an exact test, just a rough one to get an idea.
I tried not to use the pc much while running the tests. I used AbsoluteTiming[] to measure cpu.
Here is screen shot of the tables generated
Here is the test code:
methods = {nasser, wizard1, wizard2, wizard3, kguler, leonid1,
leonid2, thies};
AppendTo[$ContextPath, "Internal`"];
ClearAll[linkedList, leonid2];
SetAttributes[linkedList, HoldAllComplete];
nasser[lst_] := Module[{m = Length[lst]},
First#Reap[Do[Sow[lst[[1 ;; i]]], {i, 1, m}]][[2]]
];
wizard1[lst_] := Module[{},
Take[lst, #] & /# Range#Length#lst
];
wizard2[lst_] := Module[{},
Table[Take[#, i], {i, Length##}] & #lst
];
wizard3[lst_] := Module[{},
Rest#FoldList[Append, {}, #] & #lst
];
kguler[lst_] := Module[{},
Reverse#NestList[Most, #, Length[#] - 1] & #lst
];
leonid1[lst_] := Module[{b = Bag[{}]},
Map[(StuffBag[b, #]; BagPart[b, All]) &, lst]
];
leonid2[lst_] := Module[{},
Map[List ## Flatten[#, Infinity, linkedList] &,
FoldList[linkedList, linkedList[First#lst], Rest#lst]]
];
thies[lst_] :=
Module[{},
Drop[Reverse#
FixedPointList[If[Length[#] > 0, Most, Identity][#] &, lst], 2]
];
makeTable[n_, methods_] :=
Module[{nTests = Length[methods], nTries = 5, i, j, tests, lst},
lst = Table[RandomReal[], {n}];
tests = Table[0, {nTests}, {nTries}];
For[i = 1, i <= nTests, i++,
For[j = 1, j <= nTries, j++,
tests[[i, j]] = First#AbsoluteTiming[methods[[i]][lst] ]
]
];
tbl = Table[{ToString[methods[[i]]], Mean[ tests[[i, All]] ]}, {i,
nTests}] ;
Grid[Join[{{"method", "cpu"}}, tbl],
Frame -> All, FrameStyle -> Directive[Thickness[.005], Gray],
Spacings -> {0.5, 1}
]
];
Now to run, do
makeTable[1000, methods]
Warning, do not try something over 30,000 unless you have zillion GB, else M might not return. It happened to me, and had to reboot the PC.
update 12/26/11 3:30PM
I see that Thies has a newer version of this algorithm (I called it thies2 in the methods table), so I re-run everything again, here is the updated table, I removed the linked list version since it is known in advance not to be fast for large n, and this time, I run them each for 10 times (not 5 as above) and then took the mean). I also started M fresh using factory setting (restarted it holding alt-shift keys so that all setting are back to original settings just in case)
conclusion so far
Kugler is fastest for smaller n, i.e. n<20,000.
For larger n, now Thies second version is faster than Thies version 1 and now it edges ahead ever so slightly ahead of Kugler method for large n. Congratulation to Thies, the current lead in this performance test. But for all practical purposes, I would say both Thies and Kugler methods are the fastest for large n, and Kugler remain the fastest for smaller n.
Below are tables and the updated test code below them. Any one is free to run the tests for themselves, just in case I might overlooked something.
The current test code:
$MinPrecision = $MachinePrecision;
$MaxPrecision = $MachinePrecision;
methods = {nasser, wizard1, wizard2, wizard3, kguler, leonid, thies1,
thies2};
AppendTo[$ContextPath, "Internal`"];
nasser[lst_] := Module[{m = Length[lst]},
First#Reap[Do[Sow[lst[[1 ;; i]]], {i, 1, m}]][[2]]
];
wizard1[lst_] := Module[{},
Take[lst, #] & /# Range#Length#lst
];
wizard2[lst_] := Module[{},
Table[Take[#, i], {i, Length##}] & #lst
];
wizard3[lst_] := Module[{},
Rest#FoldList[Append, {}, #] & #lst
];
kguler[lst_] := Module[{},
Reverse#NestList[Most, #, Length[#] - 1] & #lst
];
leonid[lst_] := Module[{b = Bag[{}]},
Map[(StuffBag[b, #]; BagPart[b, All]) &, lst]
];
thies1[lst_] :=
Module[{},
Drop[Reverse#
FixedPointList[If[Length[#] > 0, Most, Identity][#] &, lst], 2]
];
thies2[lst_] :=
Module[{},
Drop[Reverse#
FixedPointList[If[# =!= {}, Most, Identity][#] &, lst], 2]
];
makeTable[n_Integer, methods_List] :=
Module[{nTests = Length[methods], nTries = 10, i, j, tests, lst},
lst = Table[RandomReal[], {n}];
tests = Table[0, {nTests}, {nTries}];
For[i = 1, i <= nTests, i++,
For[j = 1, j <= nTries, j++,
tests[[i, j]] = First#AbsoluteTiming[methods[[i]][lst] ]
]
];
tbl = Table[{ToString[methods[[i]]], Mean[ tests[[i, All]] ]}, {i,
nTests}] ;
Grid[Join[{{"method", "cpu"}}, tbl],
Frame -> All, FrameStyle -> Directive[Thickness[.005], Gray],
Spacings -> {0.5, 1}
]
];
To run type
n=1000
makeTable[n, methods]
Thanks for everyone for their answers, I learned from all of them.
You can use
f = Reverse#NestList[Most, #, Length[#] - 1] &
f#{a,b,c,d,e} gives {{a}, {a, b}, {a, b, c}, {a, b, c, d}, {a, b, c, d, e}}.
An alternative using ReplaceList -- much slower than f, but ... why not?:
g = ReplaceList[#, {x__, ___} -> {x}] &
I propose this:
runs[lst_] := Take[lst, #] & /# Range#Length#lst
Or this:
runs2 = Table[Take[#, i], {i, Length##}] &;
kguler's answer inspired me to write this:
Rest#FoldList[Append, {}, #] &
But this is slower than his method because of Mathematica's slow appends.
Here is another method which is roughly as efficient as the one involving Take, but uses the Internal`Bag functionality:
AppendTo[$ContextPath, "Internal`"];
runsB[lst_] :=
Module[{b = Bag[{}]}, Map[(StuffBag[b, #]; BagPart[b, All]) &, lst]];
I don't claim that it is simpler than the one based on Take, but it seems to be a simple example of Internal`Bag at work - since this is exactly the type of problem for which these can be successfully used (and there might be cases where lists of explicit positions would either not be available or expensive to compute).
Just to compare, the solution based on linked lists:
ClearAll[linkedList, runsLL];
SetAttributes[linkedList, HoldAllComplete];
runsLL[lst_] :=
Map[List ## Flatten[#, Infinity, linkedList] &,
FoldList[linkedList, linkedList[First#lst], Rest#lst]]
will be an order of magnitude slower on large lists.
Another idea:
Inits[l_] := Drop[Reverse#FixedPointList[
If[Length[#] > 0, Most, Identity][#] &,
l
], 2];
Update:
This version is a bit faster by omitting computing the length each time:
Inits2[l_] := Drop[Reverse#FixedPointList[
If[# =!= {}, Most, Identity][#] &,
l
], 2];
Probably not the most efficient, but another approach:
dow[lst_] := lst[[1 ;; #]] & /# Range#Length#lst
For example:
dow[{a, b, c, d, ee}]
gives:
{{a}, {a, b}, {a, b, c}, {a, b, c, d}, {a, b, c, d, ee}}
How can I get the indices of a selection rather than the values. I.e.
list={3->4, 5->2, 1->1, 5->8, 3->2};
Select[list, #[[1]]==5&]; (* returns {5->2, 5->8} *)
I would like something like
SelectIndices[list, #[[1]]==5&]; (* returns {2, 4} *)
EDIT: I found an answer to the immediate question above (see below), but what about sorting. Say I want to sort a list but rather than returning the sorted list, I want to return the indices in the order of the sorted list?
Ok, well, I figured out a way to do this. Mathematica uses such a different vocabulary that searching the documentation still is generally unfruitful for me (I had been searching for things like, "Element index from Mathematica Select", to no avail.)
Anyway, this seems to be the way to do this:
Position[list, 5->_];
I guess its time to read up on patterns in Mathematica.
WRT to the question remaining after your edit: How about Ordering?
In[26]:= Ordering[{c, x, b, z, h}]
Out[26]= {3, 1, 5, 2, 4}
In[28]:= {c, x, b, z, h}[[Ordering[{c, x, b, z, h}]]]
Out[28]= {b, c, h, x, z}
In[27]:= Sort[{c, x, b, z, h}]
Out[27]= {b, c, h, x, z}
I think you want Ordering:
Sort[list, #[[1]] == 5 &]
Ordering[list, All, #[[1]] == 5 &]
(*
{5->2,5->8,3->2,1->1,3->4}
{2,4,5,3,1}
*)
Sorry, I had read your question to fast.
I think your second question is about how to sort the list according to the values of the rules. The simplest way that come to mind is by using a compare function. then simply use your solution to retrieve the indices:
comp[_ -> x_, a_ -> y_] := x < y;
Position[Sort[list, comp], 5 -> _]
Hope this helps!
Without sorting or otherwise altering the list, do this:
SelectIndex[list_, fn_] := Module[{x},
x = Reap[For[i = 1, i < Length[list], i++, If[fn[list[[i]]], Sow[i], Null];]];
If[x[[1]] == {}, {}, x[[2, 1]]]]
list={ {"foo",1}, {"bar",2}};
SelectIndex[list, StringMatchQ[ #[[1]], "foo*"] &]
You can use that to extract records from a database
Lookup[list_, query_, column_: 1, resultColumns_: All] := list[[SelectIndex[list, StringMatchQ[query, #[[column]]] &], resultColumns]]
Lookup(list,"foo")
I'm currently doing some normalization along the lines of:
J = Integrate[Psi[x, 0]^2, {x, 0, a}]
sol = Solve[J == 1, A]
A /. sol
For this type of normalization, the negative square root is extraneous. The result of this calculation is:
In[49]:= J = Integrate[Psi[x, 0]^2, {x, 0, a}]
Out[49]= 2 A^2
In[68]:= sol = Solve[J == 1, A]
Out[68]= {{A -> -(1/Sqrt[2])}, {A -> 1/Sqrt[2]}}
Even if I try giving it an Assuming[...] or Simplify[...], it still gives me the same results:
In[69]:= sol = Assuming[A > 0, Solve[J == 1, A]]
Out[69]= {{A -> -(1/Sqrt[2])}, {A -> 1/Sqrt[2]}}
In[70]:= sol = FullSimplify[Solve[J == 1, A], A > 0]
Out[70]= {{A -> -(1/Sqrt[2])}, {A -> 1/Sqrt[2]}}
Can anyone tell me what I'm doing wrong here?
I'm running Mathematica 7 on Windows 7 64-bit.
ToRules does what the box says: converts equations (as in Reduce output) to rules. In your case:
In[1]:= ToRules[Reduce[{x^2==1,x>0},x]]
Out[1]= {x->1}
In[2]:= {ToRules[Reduce[{x^2==1},x]]}
Out[2]= {{x->-1},{x->1}}
For more complex cases, I have often found it useful to just check the value of the symbolic solutions after pluging in typical parameter values. This is not foolproof, of course, but if you know there is one and only one solution then it is a simple and efficient method:
Solve[x^2==someparameter,x]
Select[%,((x/.#)/.{someparameter-> 0.1})>0&]
Out[3]= {{x->-Sqrt[someparameter]},{x->Sqrt[someparameter]}}
Out[4]= {{x->Sqrt[someparameter]}}
Solve doesn't work like this. You might try Reduce, instead, e.g.
In[1]:= Reduce[{x^2 == 1, x > 0}, x]
Out[1]= x == 1
It's then a little tricky to transform this output to replacement rules, at least in the general case, because Reduce might use arbitrary many logical connectives. In this case, we could just hack:
In[2]:= Solve[Reduce[{x^2 == 1, x > 0}, x], x]
Out[2]= {{x->1}}