Circular/Angular slider - wolfram-mathematica

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}
]

Related

Trouble using position in wolfram-mathematica

Hi im coding a homework in mathematica about finding the probability of a program failing, make a plot and a table with the results however Im having trouble getting the last value of the table
Clear[bin1]
bin1[n_, p_, k_] :=
Module[{prob = (1 - p)^n, i},
Do[prob = (((n - i + 1)/i) (p/(1 - p))) prob, {i, k}]; prob]
distribution =
Table[bin1[50, #, k], {k, 0, 50}] & /# Range[0, .9, .1];
thats the probability calculator
prob = Max[Take[distribution, {#}]] & /# Range[1, 10] thats to take the first value of the table (its the porcentage of failiure)
position = # & /# Range[0, .9, .1](thats just for the third value)
max = Last[
Last[Position[distribution, Take[prob {#}] & /# Range[1, 10]]]]
thats the third value and where i have trouble its supossed to be tha maximum value but the prob{#} part doesnt work i have no idea why
The final table should be: TableForm[{position, prob, max}]
See the documentation for Module:
Module[{x,y,…},expr]
specifies that occurrences of the symbols x, y, … in expr should be treated as local.
When you say bin1[n_, p_, k_] := Module[{prob = …}], then prob is only defined inside the Module, and has no value outside.
You can see how this works by playing with it:
In[1]:= Module[{foo}, foo]
Out[1]= foo$185
Module renames variables inside its scope to have unique names not accessible outside.
You’ll probably need another function to compute prob, or set up bin1[] to compute both distribution and probability.

Nsolve rantz not possible to plot

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

Mathematica fast 2D binning algorithm

I am having some trouble developing a suitably fast binning algorithm in Mathematica. I have a large (~100k elements) data set of the form
T={{x1,y1,z1},{x2,y2,z2},....}
and I want to bin it into a 2D array of around 100x100 bins, with the bin value being given by the sum of the Z values that fall into each bin.
Currently I am iterating through each element of the table, using Select to pick out which bin it is supposed to be in based on lists of bin boundaries, and adding the z value to a list of values occupying that bin. At the end I map Total onto the list of bins, summing their contents (I do this because I sometimes want to do other things, like maximize).
I have tried using Gather and other such functions to do this but the above method was ridiculously faster, though perhaps I am using Gather poorly. Anyway It still takes a few minutes to do the sorting by my method and I feel like Mathematica can do better. Does anyone have a nice efficient algorithm handy?
Here is a method based on Szabolcs's post that is about about an order of magnitude faster.
data = RandomReal[5, {500000, 3}];
(*500k values*)
zvalues = data[[All, 3]];
epsilon = 1*^-10;(*prevent 101 index*)
(*rescale and round (x,y) coordinates to index pairs in the 1..100 range*)
indexes = 1 + Floor[(1 - epsilon) 100 Rescale[data[[All, {1, 2}]]]];
res2 = Module[{gb = GatherBy[Transpose[{indexes, zvalues}], First]},
SparseArray[
gb[[All, 1, 1]] ->
Total[gb[[All, All, 2]], {2}]]]; // AbsoluteTiming
Gives about {2.012217, Null}
AbsoluteTiming[
System`SetSystemOptions[
"SparseArrayOptions" -> {"TreatRepeatedEntries" -> 1}];
res3 = SparseArray[indexes -> zvalues];
System`SetSystemOptions[
"SparseArrayOptions" -> {"TreatRepeatedEntries" -> 0}];
]
Gives about {0.195228, Null}
res3 == res2
True
"TreatRepeatedEntries" -> 1 adds duplicate positions up.
I intend to do a rewrite of the code below because of Szabolcs' readability concerns. Until then, know that if your bins are regular, and you can use Round, Floor, or Ceiling (with a second argument) in place of Nearest, the code below will be much faster. On my system, it tests faster than the GatherBy solution also posted.
Assuming I understand your requirements, I propose:
data = RandomReal[100, {75, 3}];
bins = {0, 20, 40, 60, 80, 100};
Reap[
Sow[{#3, #2}, bins ~Nearest~ #] & ### data,
bins,
Reap[Sow[#, bins ~Nearest~ #2] & ### #2, bins, Tr##2 &][[2]] &
][[2]] ~Flatten~ 1 ~Total~ {3} // MatrixForm
Refactored:
f[bins_] := Reap[Sow[{##2}, bins ~Nearest~ #]& ### #, bins, #2][[2]] &
bin2D[data_, X_, Y_] := f[X][data, f[Y][#2, #2~Total~2 &] &] ~Flatten~ 1 ~Total~ {3}
Use:
bin2D[data, xbins, ybins]
Here's my approach:
data = RandomReal[5, {500000, 3}]; (* 500k values *)
zvalues = data[[All, 3]];
epsilon = 1*^-10; (* prevent 101 index *)
(* rescale and round (x,y) coordinates to index pairs in the 1..100 range *)
indexes = 1 + Floor[(1 - epsilon) 100 Rescale[data[[All, {1, 2}]]]];
(* approach 1: create bin-matrix first, then fill up elements by adding zvalues *)
res1 = Module[
{result = ConstantArray[0, {100, 100}]},
Do[
AddTo[result[[##]], zvalues[[i]]] & ## indexes[[i]],
{i, Length[indexes]}
];
result
]; // Timing
(* approach 2: gather zvalues by indexes, add them up, convert them to a matrix *)
res2 = Module[{gb = GatherBy[Transpose[{indexes, zvalues}], First]},
SparseArray[gb[[All, 1, 1]] -> (Total /# gb[[All, All, 2]])]
]; // Timing
res1 == res2
These two approaches (res1 & res2) can handle 100k and 200k elements per second, respectively, on this machine. Is this sufficiently fast, or do you need to run this whole program in a loop?
Here's my approach using the function SelectEquivalents defined in What is in your Mathematica tool bag? which is perfect for a problem like this one.
data = RandomReal[100, {75, 3}];
bins = Range[0, 100, 20];
binMiddles = (Most#bins + Rest#bins)/2;
nearest = Nearest[binMiddles];
SelectEquivalents[
data
,
TagElement -> ({First#nearest[#[[1]]], First#nearest[#[[2]]]} &)
,
TransformElement -> (#[[3]] &)
,
TransformResults -> (Total[#2] &)
,
TagPattern -> Flatten[Outer[List, binMiddles, binMiddles], 1]
,
FinalFunction -> (Partition[Flatten[# /. {} -> 0], Length[binMiddles]] &)
]
If you would want to group according to more than two dimensions you could use in FinalFunction this function to give to the list result the desired dimension (I don't remember where I found it).
InverseFlatten[l_,dimensions_]:= Fold[Partition[#, #2] &, l, Most[Reverse[dimensions]]];

Memoized recursive functions. How to make them fool-proof?

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 ...

Is there a faster way to find both Min and Max values?

Often I have written: {Min##, Max##} &
Yet this seems inefficient, as the expression must be scanned twice, once to find the minimum value, and once to find the maximum value. Is there a faster way to do this? The expression is often a tensor or array.
This beats it by a bit.
minMax = Compile[{{list, _Integer, 1}},
Module[{currentMin, currentMax},
currentMin = currentMax = First[list];
Do[
Which[
x < currentMin, currentMin = x,
x > currentMax, currentMax = x],
{x, list}];
{currentMin, currentMax}],
CompilationTarget -> "C",
RuntimeOptions -> "Speed"];
v = RandomInteger[{0, 1000000000}, {10000000}];
minMax[v] // Timing
I think it's a little faster than Leonid's version because Do is a bit faster than For, even in compiled code.
Ultimately, though, this is an example of the kind of performance hit you take when using a high level, functional programming language.
Addition in response to Leonid:
I don't think that the algorithm can account for all the time difference. Much more often than not, I think, both tests will be applied anyway. The difference between Do and For is measurable, however.
cf1 = Compile[{{list, _Real, 1}},
Module[{sum},
sum = 0.0;
Do[sum = sum + list[[i]]^2,
{i, Length[list]}];
sum]];
cf2 = Compile[{{list, _Real, 1}},
Module[{sum, i},
sum = 0.0;
For[i = 1, i <= Length[list],
i = i + 1, sum = sum + list[[i]]^2];
sum]];
v = RandomReal[{0, 1}, {10000000}];
First /#{Timing[cf1[v]], Timing[cf2[v]]}
{0.685562, 0.898232}
I think this is as fast as it gets, within Mathematica programming practices. The only way I see to attempt to make it faster within mma is to use Compile with the C compilation target, as follows:
getMinMax =
Compile[{{lst, _Real, 1}},
Module[{i = 1, min = 0., max = 0.},
For[i = 1, i <= Length[lst], i++,
If[min > lst[[i]], min = lst[[i]]];
If[max < lst[[i]], max = lst[[i]]];];
{min, max}], CompilationTarget -> "C", RuntimeOptions -> "Speed"]
However, even this seems to be somewhat slower than your code:
In[61]:= tst = RandomReal[{-10^7,10^7},10^6];
In[62]:= Do[getMinMax[tst],{100}]//Timing
Out[62]= {0.547,Null}
In[63]:= Do[{Min##,Max##}&[tst],{100}]//Timing
Out[63]= {0.484,Null}
You probably can write the function entirely in C, and then compile and load as dll - you may eliminate some overhead this way, but I doubt that you will win more than a few percents - not worth the effort IMO.
EDIT
It is interesting that you may significantly increase the speed of the compiled solution with manual common subexpression elimination (lst[[i]] here):
getMinMax =
Compile[{{lst, _Real, 1}},
Module[{i = 1, min = 0., max = 0., temp},
While[i <= Length[lst],
temp = lst[[i++]];
If[min > temp, min = temp];
If[max < temp, max = temp];];
{min, max}], CompilationTarget -> "C", RuntimeOptions -> "Speed"]
is a little faster than {Min##,Max##}.
For an array, you could do the simplest functional thing and use
Fold[{Min[##],Max[##]}&, First##, Rest##]& # data
Unfortunately, it is no speed demon. Even for short lists, 5 elements, all of Leonid's answers and Mark's answer are at least 7 times faster, uncompiled in v.7. For long lists, 25000 elements, this gets worse with Mark's being 19.6 times faster, yet even at this length this solution took only about 0.05 secs to run.
However, I'd not count out {Min[#], Max[#]}& as an option. Uncompiled it was 1.7 times faster than Mark's for short list and nearly 15 times faster for long lists (8 times and nearly 300 times faster, respectively, than the Fold solution).
Unfortunately, I could not get good numbers for the compiled versions of either {Min[#], Max[#]}&, Leonid's, or Mark's answers, instead I got numerous incomprehensible error messages. In fact, {Min[#], Max[#]}& increased in execution time. The Fold solution improved dramatically, though, and took twice as long as Leonid's answers' uncompiled times.
Edit: for the curious, here's some timing measurements of the uncompiled functions -
Each function was used on 100 lists of the length specified on the horizontal axis and the average time, in seconds, is the vertical axis. In ascending order of time, the curves are {Min[#], Max[#]}&, Mark's answer, Leonid's second answer, Leonid's first answer, and the Fold method from above.
For all of you who are doing timings I'd like to warn you that order of execution is extremely important. For instance, look at the following two subtly different timings tests:
(1)
res =
Table[
a = RandomReal[{0, 100}, 10^8];
{
Min[a] // AbsoluteTiming // First, Max[a] // AbsoluteTiming // First,
Max[a] // AbsoluteTiming // First, Min[a] // AbsoluteTiming // First
}
, {100}
]
The odd man out here is the last Min
(2)
res =
Table[
a = RandomReal[{0, 100}, 10^8];
{
Max[a] // AbsoluteTiming // First, Min[a] // AbsoluteTiming // First,
Min[a] // AbsoluteTiming // First, Max[a] // AbsoluteTiming // First
}
, {100}
]
Here, the highest timing is found for the first Max, the second-highest for the second max and the two Mins are about the same and lowest. Actually, I'd expect Max and Min to take about the same time,but they don't. The former seems to take 50% more time than the latter. Having the pole position also seems to come with a 50% handicap.
Now a comparison with the algorithms given by Mark and Leonid:
res =
Table[
a = RandomReal[{0, 100}, 10^8];
{
{Max[a], Min[a]} // AbsoluteTiming // First,
{Min##, Max##} &#a // AbsoluteTiming // First,
getMinMax[a] // AbsoluteTiming // First,
minMax[a] // AbsoluteTiming // First,
{Min[a], Max[a]} // AbsoluteTiming // First
}
, {100}
]
Here we find about .3 s for the {Max[a], Min[a]} (which includes the pole position handicap), the .1 level is for Mark's method; the others are all about the same.

Resources