I am using the FindRoot statement. My problem is that the results
are only in symbolic form. How can I get mathematica to store results as a vector
or list for easy use later.
g[r_]:=(A^r - 1)/(A^r - B^r);
func[r_]:= Piecewise[{{g[r],r<-.01 },{ g[r],r>.01} }];
roots = Table[0,{10}];
q= Table[pp,{pp,.01,0.1,0.01}];
Do[ roots[[i]]=FindRoot[func[r]== q[[i]],{r,0.9}];,{i,1,10}]; ********
Print[r/.roots]; *********** this prints out ok as a list
Pa2=Table[0,{10}];
myPa2=Table[0,{10}];
i/:IntegerQ[i]=True;
r2=r;
h[r2_]:=(A^r2 - 1)/(A^r2 - B^r2);
funcOC[r2_]:= Piecewise[{{h[r2],r2<-.01 },{ h[r2],r2>.01} }];
Do[ Pa2[[i]]=funcOC[r2[[i]]], {i,1,10} ];
Print[myPa2/.Pa2]; ****************symbolic notation is output
To expand on Michael's question the code, as it currently stands, does not produce numerical values because the values of A and B have not been set.
If values are chosen for A and B FindRoot no longer returns a symbolic answer.
g[r_] := (A^r - 1)/(A^r - B^r);
A = .4; B = .5;
func[r_] := Piecewise[{{g[r], r < -.01}, {g[r], r > .01}}];
roots = Table[0, {10}];
q = Table[pp, {pp, .01, 0.1, 0.01}];
Do[roots[[i]] = FindRoot[func[r] == q[[i]], {r, 0.9}];, {i, 1, 10}];
Print[r /. roots];
{-201.021,-198.983,-196.97,-194.98,-186.987,-178.398,-170.282,-162.61,-155.352,-148.484}
For your second block of code I assume your problem is caused by r2[[i]] in:
Do[ Pa2[[i]]=funcOC[r2[[i]]], {i,1,10} ];
I think you meant:
Do[ Pa2[[i]]=funcOC[i], {i,1,10} ];
Did you mean to use the roots you found in your first block of code? If so you need to replace.
r2=r;
with
r2=r /. roots;
Related
I have a problem to plot a solution of a system of equotations in Mathematica. My system of equotations has two variables (s12 and t). It's not possible to solve it explicitly (s12:=f(t)), but I am able to get a solution for each positive t. But what I want, is a plot with t on the x-achses and s12(t) on the y-achses.
My best gues is that since I get the single solution always with the comment
"*Solve::ratnz: Solve was unable to solve the system with inexact coefficients. The answer was obtained by solving a corresponding exact system and numericizing the result*" this doesn not work with infinite solution for mathematica.
I might have to surpress this warning or does anyone has another idea?. I only need a rough plot.
The problem is as follows:
ClearAll["Global`*"];
cinv1 = 40;
cinv2 = 4;
cinv3 = 3;
h2 = 1.4;
h3 = 1.2;
alpha = 0.04;
z = 20;
p = 0.06;
cop1 = 0;
cop2 = 1;
cop3 = 1.5;
l2 = 0.1;
l3 = 0.17;
teta2 = 0.19;
teta3 = 0.1;
co2 = -0.1;
smax = 40;
c = 1;
Plot[Solve[{s12 == ((cinv1 -
cinv2) + ((cinv2 - cinv3)*((s12 teta2)/(
Sqrt[ (teta2 - teta3)] Sqrt[
c s12^2 teta2 - (2 alpha z)/c]))))/((1/(teta2 -
teta3))*((teta2*cop3 - teta3*cop2) + (teta2*h3*l3*E^(p*t) -
teta3*h2*l2*E^(p*t)))), s12 > 0}, s12, Reals], {t, 0, 10}]
As already said, when I use a specific t, I get a solution, otherwise I receive the message as follows:
"*Solve::ratnz: Solve was unable to solve the system with inexact coefficients. The answer was obtained by solving a corresponding exact system and numericizing the result*"
"*Solve::ratnz: Solve was unable to solve the system with inexact coefficients. The answer was obtained by solving a corresponding exact system and numericizing the result*"
"*Solve::ratnz: Solve was unable to solve the system with inexact coefficients. The answer was obtained by solving a corresponding exact system and numericizing the result*"
*"General::stop: "Further output of \!\(\*
StyleBox[
RowBox[{\"Solve\", \"::\", \"ratnz\"}], \"MessageName\"]\) will be suppressed during this calculation""*
Thanks a lot for your help,
Andreas
The system has 4 solutions, 3 of them positive in the range of interest:
s2 = Solve[{s12 - ((cinv1 - cinv2) + ((cinv2 - cinv3) ((s12 teta2)/
(Sqrt[(teta2 - teta3)] Sqrt[c s12^2 teta2 - (2 alpha z)/c]))))/
((1/(teta2 - teta3))*((teta2*cop3 - teta3*cop2) +
(teta2*h3*l3*E^(p*t) - teta3*h2*l2*E^(p*t))))} == 0, s12];
Plot[s12 /. s2 , {t, 0, 59}]
Important fact to add:
The proposed solution above is correct, but it uses complex numbers to solve. The graph in the solution above shows only the real part of the complex number. This might lead to some confusion as it did to me.
Though, there is a solution with solely real numbers. Since Mathematica cannot solve the equotation in a "continous way" with real numbers, I finally did a three step approach:
I solved the equotation at discrete points in time
I plotted the solution with ListLinePlot.
I used Interpolation[] to allow for rough detection of intresections with other curves
a = Table[NSolve[{s12 - ((cinv1 - cinv2) +
((cinv2 - cinv3)*((s12 teta2)/(\[Sqrt] (teta2 - teta3)
\[Sqrt](c s12^2 teta2 - (2 alpha z)/c)))))/
((1/(teta2 - teta3))*((teta2*cop3 -teta3*cop2) + (teta2*h3*l3*E^(p*t) -
teta3*h2*l2*E^(p*t)))) == 0}, s12][[1]], {t, 0, 100}];
b = Table[t, {t, 0, 100}];
f1a = s12 /. a;
f1 = Transpose[{b, f1a}];
ceiling1 = ListLinePlot[{f1},
PlotRange -> {{0, 20}, {0, 40}},PlotStyle -> {Black, Dotted, Thickness[0.003]}];
In a next step I also needed to find the intersection of multiple curves created that way. To get a rough estimate, I did the following:
curve1 = Interpolation[f1];
intersec2a = FindRoot[curve1[x2] - t12[x2, l2], {x2, 0}];
intersec2 = x2 /. intersec2a;
Hope this helps
I want to test if a list contains consecutive integers.
consQ[a_] := Module[
{ret = True},
Do[If[i > 1 && a[[i]] != a[[i - 1]] + 1, ret = False; Break[]], {i,
1, Length[a]}]; ret]
Although the function consQ does the job, I wonder if there is a better ( shorter, faster ) method of doing this, preferably using functional programming style.
EDIT:
The function above maps lists with consecutive integers in decreasing sequence to False. I would like to change this to True.
Szablics' solution is probably what I'd do, but here's an alternative:
consQ[a : {___Integer}] := Most[a] + 1 === Rest[a]
consQ[_] := False
Note that these approaches differ in how they handle the empty list.
You could use
consQ[a_List ? (VectorQ[#, IntegerQ]&)] := Union#Differences[a] === {1}
consQ[_] = False
You may want to remove the test for integers if you know that every list you pass to it will only have integers.
EDIT: A little extra: if you use a very old version that doesn't have Differences, or wonder how to implement it,
differences[a_List] := Rest[a] - Most[a]
EDIT 2: The requested change:
consQ[a : {Integer___}] := MatchQ[Union#Differences[a], {1} | {-1} | {}]
consQ[_] = False
This works with both increasing and decreasing sequences, and gives True for a list of size 1 or 0 as well.
More generally, you can test if the list of numbers are equally spaced with something like equallySpacedQ[a_List] := Length#Union#Differences[a] == 1
I think the following is also fast, and comparing reversed lists does not take longer:
a = Range[10^7];
f[a_] := Range[Sequence ## ##, Sign[-#[[1]] + #[[2]]]] &#{a[[1]], a[[-1]]} == a;
Timing[f[a]]
b = Reverse#a;
Timing[f[b]]
Edit
A short test for the fastests solutions so far:
a = Range[2 10^7];
Timing#consQSzab#a
Timing#consQBret#a
Timing#consQBeli#a
(*
{6.5,True}
{0.703,True}
{0.203,True}
*)
I like the solutions by the other two, but I'd be concerned about very long lists. Consider the data
d:dat[n_Integer?Positive]:= d = {1}~Join~Range[1, n]
which has its non-sequential point at the very beginning. Setting consQ1 for Brett's and consQ2 for Szabolcs, I get
AbsoluteTiming[ #[dat[ 10000 ] ]& /# {consQ1, consQ2}
{ {0.000110, False}, {0.001091, False} }
Or, roughly a ten times difference between the two, which stays relatively consistent with multiple trials. This time can be cut in roughly half by short-circuiting the process using NestWhile:
Clear[consQ3]
consQ3[a : {__Integer}] :=
Module[{l = Length[a], i = 1},
NestWhile[# + 1 &, i,
(#2 <= l) && a[[#1]] + 1 == a[[#2]] &,
2] > l
]
which tests each pair and only continues if they return true. The timings
AbsoluteTiming[consQ3[dat[ 10000 ]]]
{0.000059, False}
with
{0.000076, False}
for consQ. So, Brett's answer is fairly close, but occasionally, it will take twice as long.
Edit: I moved the graphs of the timing data to a Community Wiki answer.
Fold can be used in a fairly concise expression that runs very quickly:
consQFold[a_] := (Fold[If[#2 == #1 + 1, #2, Return[False]] &, a[[1]]-1, a]; True)
Pattern-matching can be used to provide a very clear expression of intent at the cost of substantially slower performance:
consQMatch[{___, i_, j_, ___}] /; j - i != 1 := False
consQMatch[_] = True;
Edit
consQFold, as written, works in Mathematica v8.0.4 but not in earlier versions of v8 or v7. To correct this problem, there are a couple of alternatives. The first is to explicitly name the Return point:
consQFold[a_] :=
(Fold[If[#2==#1+1, #2, Return[False,CompoundExpression]] &, a[[1]]-1, a]; True)
The second, as suggested by #Mr.Wizard, is to replace Return with Throw / Catch:
consQFold[a_] :=
Catch[Fold[If[#2 == #1 + 1, #2, Throw[False]]&, a[[1]]-1, a]; True]
Since the timing seems to be rather important. I've moved the comparisons between the various methods to this, Community Wiki, answer.
The data used are simply lists of consecutive integers, with a single non-consecutive point, and they're generated via
d : dat[n_Integer?Positive] := (d = {1}~Join~Range[1, n])
d : dat[n_Integer?Positive, p_Integer?Positive] /; p <= n :=
Range[1, p]~Join~{p}~Join~Range[p + 1, n]
where the first form of dat[n] is equivalent to dat[n, 1]. The timing code is simple:
Clear[consQTiming]
Options[consQTiming] = {
NonConsecutivePoints -> {10, 25, 50, 100, 250,500, 1000}};
consQTiming[fcns__, OptionPattern[]]:=
With[{rnd = RandomInteger[{1, #}, 100]},
With[{fcn = #},
Timing[ fcn[dat[10000, #]] & /# rnd ][[1]]/100
] & /# {fcns}
] & /# OptionValue[NonConsecutivePoints]
It generates 100 random integers between 1 and each of {10, 25, 50, 100, 250, 500, 1000} and dat then uses each of those random numbers as the non-consecutive point in a list 10,000 elements long. Each consQ implementation is then applied to each list produced by dat, and the results are averaged. The plotting function is simply
Clear[PlotConsQTimings]
Options[PlotConsQTimings] = {
NonConsecutivePoints -> {10, 25, 50, 100, 250, 500, 1000}};
PlotConsQTimings[timings : { _?VectorQ ..}, OptionPattern[]] :=
ListLogLogPlot[
Thread[{OptionValue[NonConsecutivePoints], #}] & /# Transpose[timings],
Frame -> True, Joined -> True, PlotMarkers -> Automatic
]
I timed the following functions consQSzabolcs1, consQSzabolcs2, consQBrett, consQRCollyer, consQBelisarius, consQWRFold, consQWRFold2, consQWRFold3, consQWRMatch, and MrWizard's version of consQBelisarius.
In ascending order of the left most timing: consQBelisarius, consQWizard, consQRCollyer, consQBrett, consQSzabolcs1, consQWRMatch, consQSzabolcs2, consQWRFold2, consQWRFold3,and consQWRFold.
Edit: Reran all of the functions with timeAvg (the second one) instead of Timing in consQTiming. I did still average over 100 runs, though. For the most part, there was any change, except for the lowest two where there is some variation from run to run. So, take those two lines with a grain of salt as they're timings are practically identical.
I am now convinced that belisarius is trying to get my goat by writing intentionally convoluted code. :-p
I would write: f = Range[##, Sign[#2 - #]]& ## #[[{1, -1}]] == # &
Also, I believe that WReach probably intended to write something like:
consQFold[a_] :=
Catch[
Fold[If[#2 === # + 1, #2, Throw#False] &, a[[1]] - 1, a];
True
]
Memoized functions are functions which remember values they have found.
Look in the doc center for some background on this in Mathematica, if necessary.
Suppose you have the following definition
f[0] = f[1] = 1
f[x_] := f[x] = f[x - 1] + f[x - 2]
in one of your packages. A user may load the package and start asking right away f[1000].
This will trigger a $RecursionLimit::reclim error message and abort.
Even if the user then tries something smaller, say f[20], by now the definition of f is corrupt and the result is not good anymore.Of course the package developer might increase the recursion limit and warn the user, but my question is:
How can you improve the f definition so that if the user asks for f[1000] he/she gets the answer without any problem? I am interested in a way to trap the user input, analyze it and take whatever steps are necessary to evaluate f[1000].
I can easily imagine that one can change the recursion limit if the input is more than 255 (and then bring it back to the original level), but what I would really like to see is, if there is a way for the f to find out how many values it "knows" (fknownvalues) and accept any input <=fknownvalues+$RecursionLimit without problems or increase the $RecursionLimit if the input is higher.
Thank you for your help
Here is the code assuming that you can determine a value of $RecursionLimit from the value of the input argument:
Clear[f];
Module[{ff},
ff[0] = ff[1] = 1;
ff[x_] := ff[x] = ff[x - 1] + ff[x - 2];
f[x_Integer] :=f[x] =
Block[{$RecursionLimit = x + 5},
ff[x]
]]
I am using a local function ff to do the main work, while f just calls it wrapped in Block with a proper value for $RecursionLimit:
In[1552]:= f[1000]
Out[1552]= 7033036771142281582183525487718354977018126983635873274260490508715453711819693357974224
9494562611733487750449241765991088186363265450223647106012053374121273867339111198139373125
598767690091902245245323403501
EDIT
If you want to be more precise with the setting of $RecursionLimit, you can modify the part of the code above as:
f[x_Integer] :=
f[x] =
Block[{$RecursionLimit = x - Length[DownValues[ff]] + 10},
Print["Current $RecursionLimit: ", $RecursionLimit];
ff[x]]]
The Print statement is here for illustration. The value 10 is rather arbitrary - to get a lower bound on it, one has to compute the necessary depth of recursion, and take into account that the number of known results is Length[DownValues[ff]] - 2 (since ff has 2 general definitions). Here is some usage:
In[1567]:= f[500]//Short
During evaluation of In[1567]:= Current $RecursionLimit: 507
Out[1567]//Short= 22559151616193633087251269<<53>>83405015987052796968498626
In[1568]:= f[800]//Short
During evaluation of In[1568]:= Current $RecursionLimit: 308
Out[1568]//Short= 11210238130165701975392213<<116>>44406006693244742562963426
If you also want to limit the maximal $RecursionLimit possible, this is also easy to do, along the same lines. Here, for example, we will limit it to 10000 (again, this goes inside Module):
f::tooLarge =
"The parameter value `1` is too large for single recursive step. \
Try building the result incrementally";
f[x_Integer] :=
With[{reclim = x - Length[DownValues[ff]] + 10},
(f[x] =
Block[{$RecursionLimit = reclim },
Print["Current $RecursionLimit: ", $RecursionLimit];
ff[x]]) /; reclim < 10000];
f[x_Integer] := "" /; Message[f::tooLarge, x]]
For example:
In[1581]:= f[11000]//Short
During evaluation of In[1581]:= f::tooLarge: The parameter value 11000 is too
large for single recursive step. Try building the result incrementally
Out[1581]//Short= f[11000]
In[1582]:=
f[9000];
f[11000]//Short
During evaluation of In[1582]:= Current $RecursionLimit: 9007
During evaluation of In[1582]:= Current $RecursionLimit: 2008
Out[1583]//Short= 5291092912053548874786829<<2248>>91481844337702018068766626
A slight modification on Leonid's code. I guess I should post it as a comment, but the lack of comment formatting makes it impossible.
Self adaptive Recursion Limit
Clear[f];
$RecursionLimit = 20;
Module[{ff},
ff[0] = ff[1] = 1;
ff[x_] :=
ff[x] = Block[{$RecursionLimit = $RecursionLimit + 2}, ff[x - 1] + ff[x - 2]];
f[x_Integer] := f[x] = ff[x]]
f[30]
(*
-> 1346269
*)
$RecursionLimit
(*
-> 20
*)
Edit
Trying to set $RecursionLimit sparsely:
Clear[f];
$RecursionLimit = 20;
Module[{ff}, ff[0] = ff[1] = 1;
ff[x_] := ff[x] =
Block[{$RecursionLimit =
If[Length#Stack[] > $RecursionLimit - 5, $RecursionLimit + 5, $RecursionLimit]},
ff[x - 1] + ff[x - 2]];
f[x_Integer] := f[x] = ff[x]]
Not sure how useful it is ...
This question is in a way a continuation of the question I asked here:Simple way to delete a matrix column in Mathematica to which #belisarius and #Daniel provided very helpful answers.
What I am generally trying to do is to extract from a matrix A specific lines and columns OR what remains after what those specified are removed. So this can be formally writtewn as, find TakeOperator and Drop Operator such that:
TakeOperator[A,{i1,..,ip},{j1,...,jq}]=(A[[ik]][[jl]]) (1<=k<=p, 1<=l<=q) =Table[A[[ik]][[jl]],{k,p},{l,q}]
We note Ic={i'1,...,i'p'}=Complement[{1,...,Length[A]},{i1,...,ip}];Jc={j'1,...,j'q'}=Complement[{1,...,Length[A]},{j1,...,jq}];
DropOperator[A,{i1,..,ip},{j1,...,jq}]=(A[[ik]][[jl]]) (1<=k'<=p', 1<=l'<=q') =Table[A[[ik']][[jl']],{k',p'},{l','q}]
While Table as described above does the trick, it is highly inefficient to use Table in that manner.
Just to give an idea, I took # belisarius example:
In: First#Timing[a = RandomInteger[1000, {5000, 5000}];]
Out:0.218
In:Clear[b,c]
In:First#Timing[
b = Table[
If[i < 100, If[j < 100, a[[i]][[j]], a[[i]][[j + 1]]],
If[j < 100, a[[i + 1]][[j]], a[[i + 1]][[j + 1]]]], {i,
4999}, {j, 4999}]]
Out:140.807
In:First#Timing[c = Drop[a, {100}, {100}]]
Out:0.093
In:c===b
Out:True
Note: With respect to the use of Drop in the earlier post, I thought about using it as well, but when I checked the documentation, there was no suggestion of getting it done the way #belisarius and #daniel suggested. If the documentation could be updated in that direction in future releases, it would be helpful.
Part directly supports lists of indices when slicing arrays. The following definitions exploit that:
takeOperator[a_?MatrixQ, rows_List, cols_List] :=
a[[rows, cols]]
dropOperator[a_?MatrixQ, rows_List, cols_List] :=
a[[##]]& ## complementaryIndices[a, rows, cols]
complementaryIndices[a_?MatrixQ, rows_List, cols_List] :=
Complement ### Transpose # {Range /# Dimensions # a, {rows, cols}}
Example use:
a = RandomInteger[1000, {5000, 5000}];
First # Timing # takeOperator[a, Range[1, 5000, 2], Range[1, 5000, 2]]
(* 0.016 *)
First # Timing # dropOperator[a, Range[1, 5000, 2], Range[1, 5000, 2]]
(* 0.015 *)
You can also use explicit ranges in a way that is fairly efficient. They may provide some more flexibility. Here is your example.
a = RandomInteger[1000, {5000, 5000}];
Timing[b = Drop[a, {101}, {101}];]
Out[66]= {0.041993, Null}
Timing[
c = a[[Join[Range[100], Range[102, 5000]],
Join[Range[100], Range[102, 5000]]]];]
Out[67]= {0.061991, Null}
c == b
Out[62]= True
I would also suggest use of Span except offhand I do not see how to get it to work in this setting.
Daniel Lichtblau
Wolfram Research
A recent SO question reminded me of some code I tried to write a while back. The aim is to make a CircularSlider[] object that can be used for angle-like variables in dynamic objects.
The framework for my solution (below) comes from the ValueThumbSlider[] defined in the Advanced Manipulate Functionality tutorial. The main difference is that in ValueThumbSlider[] the value of the slider and the position of the LocatorPlane[] are the same thing, whilst in my CircularSlider[] they are not - and this leads to problems.
The first problem is that moving the Locator will not change the slider value. This is fixed by using the 2nd argument in the Dynamic: (x = #/Abs[Complex ## #]) &.
This in turn leads to the problem that if you externally set the value of the slider (t) from outside, it will immediately revert to its previous value. This is fixed by keeping the old value (t0) and comparing to t. If they don't match then it's assumed that t has changed and so the Locator position x is updated to its new position.
CircularSlider[t_] := CircularSlider[t, {0, 1}];
CircularSlider[Dynamic[t_], {min_, max_}] /; max > min :=
With[{d = (max - min)/(2. Pi)},
DynamicModule[{td = t/d, x, t0}, x = {Cos[td], Sin[td]};
LocatorPane[
Dynamic[If[!NumberQ[t], t = min; x = {Cos[td], Sin[td]}];
If[t != t0, t0 = t; x = {Cos[td], Sin[td]}];
t = Mod[Arg[Complex ## x] d, max, min]; t0 = t;
x, (x = #/Abs[Complex ## #]) &],
Graphics[{AbsoluteThickness[1.5], Circle[],
Dynamic[{Text[NumberForm[t, {3, 2}], {0, 0}]}]}],
ImageSize -> Small]]]
So my question is: can someone make this work with out the above kludges?
As for problem#1, I wouldn't consider the use of the second argument to Dynamic as a kludge -- that is what the second argument is for. Therefore, I don't have an alternative solution for that one.
Problem #2 can be avoided if you refrain from assigning t in the first argument to Dynamic.
With this in mind, here is another implementation:
CircularSlider2[Dynamic[t_], r:{min_, max_}:{0, 1}] :=
DynamicModule[{scale, toXY, fromXY},
scale = (max - min) / (2. Pi);
toXY[a_?NumberQ] := Through#{Cos, Sin}[a / scale];
toXY[a_] := {1, 0};
fromXY[{x_, y_}] := Mod[Arg[x + I y] scale, max, min];
LocatorPane[
Dynamic[toXY[t], (t = fromXY[#])&],
Graphics[{
AbsoluteThickness[1.5], Circle[],
Dynamic[{Text[NumberForm[t, {3,2}], {0, 0}]}]
}],
ImageSize -> Small
]
]
The only material difference between this version and the original version is that the first argument to Dynamic is an expresssion that is free of side-effects.
Edit
I just stumbled across this undocumented experimental feature in Mathematica 8:
DynamicModule[{x = RandomReal[{0, 50}]},
{Experimental`AngularSlider[Dynamic#x], Dynamic#x}
]