Mathematica dynamic to plot matrix data - dynamic

I am trying to dynamically plot data contained in a matrix with Mathematica 7. The data is contained in it like this, obtained via a chemical model.
[year H He Li C ... C8H14+,Grain- ]
[0 0 0.03 0.009 1E-3 ... 0 ]
[100 .1 0.03 0.009 1E-3 ... 0 ]
[200 .2 0.03 0.009 1E-3 ... 0 ]
[300 .2 0.03 0.009 1E-3 ... 0 ]
[... ... ... ... ... ... ... ]
[1E6 .5 0.03 0.003 1E-8 ... 1E-25 ]
The truth is, the matrix dimensions are 2001*1476 (2000 steps and first line for name, and 1475 compounds + 1 column for year), very heavy.
I am trying to plot any compound with a concentration / year plot. This works
Manipulate[
ListLogLogPlot[data[[All, {1, i}]], PlotLabel -> data[[1, i]] ],
{{i, 2, "Compound"}, 2, compounds, 1}
]
where data is the matrix, and compounds a variable set at the number of modelized compounds (1475 here). "compound" is a label for the slider.
The problem is, the slider moves much to fast as a few centimeters browse through 1400+ items.
I tried to do a drop-down menu with
MenuView[
Table[
ListLogLogPlot[data[[All, {1, i}]],PlotLabel -> data[[1, i]]], {i, 2, compounds}
]
]
It also works, but this is a processor killer process (10+ minutes on a Xeon 16-core server executing 16 kernels), as Mathematica try to graph all plots before displaying any of them. Also the drop-down has no name, just a series of numbers (1 for hydrogen to 1475 for C8H14N+,Grain-), even though the plot has a name.
What I am searching a way to plot a graph only on demand, with a name display in the drop-down list (and if required H by default). OR a field where I can enter the name of the compound. This seems to be possible with Dynamic[ ] command, but I don't manage to make it work properly.
Thanks

Mike's suggestion is a good one but if you don't want to go to the effort of putting it in a database, use the ContinuousAction->False option.
testdata =
Join[{Table[ToString[series[i-1]], {i, 1475}]},
RandomReal[{1., 100.}, {2000, 1476}]];
Manipulate[
ListLogLogPlot[testdata[[All, {1, i}]],
PlotLabel -> testdata[[1, i]]], {{i, 2, "Compound"}, 2, 1475, 1},
ContinuousAction -> False]
To get a popup menu, use the {i,listofvalues} syntax for the controller specification.
Manipulate[
ListLogLogPlot[testdata[[All, {1, i}]],
PlotLabel -> testdata[[1, i]]], {i, Range[2, 1475]},
ContinuousAction -> False]
This works pretty fast on my system. (Two year old MacBook Pro)
A fancier version:
spec = Thread[Range[2, 1476] -> Table[ToString[series[i]], {i, 1475}]];
Manipulate[
ListLogLogPlot[testdata[[All, {1, i}]],
PlotLabel -> testdata[[1, i]]], {{i, 2, "Compound"}, spec},
ContinuousAction -> False]
And if all you want to do is step through the images, click on the little plus next to a slider controller to get more detailed controls.

For entering names in an InputField, you could do something like
compounds = Rest[data[[1]]];
Manipulate[
If[MemberQ[compounds, compound], i = Position[compounds, compound][[1, 1]] + 1];
ListLogLogPlot[data[[All, {1, i}]], PlotLabel -> data[[1, i]]],
{{i, 2}, None},
{{compound, data[[1, 2]], "Compound"}, InputField[#, String] &}]
Here, compounds is a list of all the names of the compounds. The If statement in Manipulate is to check whether the name entered in the InputField is a valid compound or not.
Others have already given you ways to create one big popup list. If you don't want to scroll through a popup list of 1475 compounds, you could consider splitting the popup list into sublists. For example, this would split the whole list of compounds into sublists of n=50 elements which might make it easier to navigate
compounds = Rest[data[[1]]];
With[{n = 50},
Manipulate[
i = 1 + Position[compounds, name][[1, 1]];
ListLogLogPlot[data[[All, {1, i}]], PlotLabel -> data[[1, i]]],
{{i, 2}, None},
{{indexlist, 1, "Indices"},
Table[i -> ToString[(i - 1) n + 1] <> " through " <>
ToString[Min[i n, Length[compounds]]],
{i, Ceiling[Length[compounds]/n]}], PopupMenu},
{{name, compounds[[1]], "Compound"},
compounds[[n (indexlist - 1) + 1 ;;
Min[Length[compounds], n indexlist]]], PopupMenu}
]
]
For example, for
data = Table[Join[{i}, RandomReal[{0, 1}, 1000]], {i, 1000}];
data = Join[{Prepend[Table["list " <> ToString[i], {i, 1000}], "year"]}, data];
this looks like

For data sets of this size I'd recommend (as optimal) storing it all in a database and using DatabaseLink to call stuff as required. Then link your controllers, such as popup menus, to SQLExecute code or other SQL functions. Fragments like this would be the sort of thing that would do the job:
DynamicModule[{x,data, ...},
Column[{
PopupMenu[Dynamic[x], {1 -> "category 1", 2 -> "category 2", 3 -> "category 3", ...}],
Dynamic[
data = SQLExecute[conn, "SELECT * FROM myDatabase.table WHERE my_id = `1`;", {x}];
ListLogLogPlot[data]
]
}]
]
In reality you may want to be adding additional popups and doing joins and so on.
EDIT
Alternative that doesn't use databases but uses input fields as requested:
DynamicModule[{x = "He", rules, y},
rules = Rule ### Transpose[{data[[1, All]], Range[Length[data[[1, All]]]]}];
Column[{
InputField[Dynamic[x], String],
Dynamic[
y = x /. rules;
ListLogLogPlot[data[[All, {1, y}]], PlotLabel -> data[[1, y]]]
]
}]
]
For rules lists of this size you'd probably want to use Dispatch I'd imagine. See how the timing goes for that. It looks like this is some sort of experiment you are running so my first choice remains dumping it into a DB.
FURTHER EDIT
If you're relying on input fields then you will need to account for clumsy typing by inserting a conditional so that Mma only attempts to plot if y is an integer.
If[IntegerQ[y],
ListLogLogPlot,
Spacer[0]
]

Related

Formatting Manipulate output to have 2 cells in Mathematica

The following output code outputs an array from the manipulate statement. I would like to output the fitting and plot as two separate output cells that update dynamically. I think it should be pretty simple, but I am having trouble with it. I've tried using the CellPrint[] function, but did not get it to work.
Thanks,
Tal
temperatures(*mK*)= {300, 200, 150, 100, 75, 50, 25, 11, 10};
F[t_, \[Nu]_] := t^\[Nu];
rd (*uOhms*)= {27173.91304, 31250., 42372.88136, 200601.80542,
1.05263*10^6, 1.33333*10^7, 1.33333*10^8, 2.*10^8, 2.1*10^8};
logRd = Log10[rd];
f[\[Nu]0_] := Module[{\[Nu]},
\[Nu] = \[Nu]0;
data = Transpose[{F[temperatures, \[Nu]]*10^3, logRd}];
fitToHexatic = LinearModelFit[data[[4 ;; 6]], x, x];
plota =
Plot[fitToHexatic["BestFit"], {x, 0, data[[-1]][[1]]},
Axes -> False];
plotb = ListPlot[data, Axes -> False];
{fitToHexatic, Show[{plota, plotb}, Axes -> True]}
]
Manipulate[
f[nu],
{nu, -0.2, -1}
]
Screenshot of the output:
You don't need to use a Manipulate. You can get more control with lower level functions. E.g.
Slider[Dynamic[nu, (f[#]; nu = #) &], {-0.2, -1}]
Dynamic[Normal[fitToHexatic]]
Dynamic[Show[{plota, plotb}, Axes -> True]]
See also Prototypical Manipulate in lower level functions.

Mathematica Manipulate & PopupMenu

I'm new here and I've one question about the Manipulate function i Mathematica: I need to plot some data of a nested list where the first coordinate selects a category (of stocks, like banks, automobiles, pharmaceuticals, ...) and inside every category there are years and months coordinates, so it should be something like
In:= list[[cat]][[yr]][[mnth]]
Out= {1,2,3,4,5,6}
which are sorted stock prices belonging to category cat.
Now I'd like to plot this with an dynamic index in Manipulate with a PopupMenu which allows to select the category i need to plot: I already have a vector sect which at position cat has the sector referring to cat in list (which is to say sect[[i]] is the category of list[[i]]), but results are poor.
I've tried to use Manipulate[...,{index,sect}] and it seems to be the right way since there actually is a popup menu in the output, but it still gives error about syntax in the control cycle I need to plot only the right sector, something like
If[ sect[[j]] == index, Plot[ list[[j]] ] ].
So I'm stuck here, thanks to anyone will help!
I'm not convinced your data structure is optimal, but here's a sample set of data:
data2 = {
{"stock",
{
Range[6], Range[6, 12],
Range[12, 18]
},
{
Range[18, 24], Range[24, 30],
Range[30, 36]
}
},
{"bank",
Table[Range[i, i + 5], {i, 1, 18, 6}],
Table[Range[i, i + 5], {i, 18, 30, 6}]
}
};
and the Manipulate:
Manipulate[ListPlot[data2[[cat, year, month]]],
{{cat, 1, "Category"}, {1 -> "stock", 2 -> "bank"},
ControlType -> PopupMenu},
{{year, 2, "Year"}, {2 -> "2010", 3 -> "2011"},
ControlType -> PopupMenu},
{{month, 1, "Month"}, {1 -> "Jan", 2 -> "Feb", 3 -> "Mar"},
ControlType -> PopupMenu}]

Mathematica: Having a plot inside a loop of a module updated

I would like to have a module like this
TestModule[n_] := Module[{{dataList = {{0, 0}, {1, 2}}}},
For[i = 1, i <= n, i++,
Pause[0.5];
Print[ ListLinePlot[dataList++]];
];
];
where a the values of a list get updated from iteration to iteration and instead of having the module producing me n plots, I rather would like to have only one plot, which is updated n times after each iteration.
I looked already at Dynamics[] and Monitor[], but could not yet find a solution with them. Any help is appreciated. :)
here is a straightforward application of Monitor:
TestModule[n_] := Module[{
dataList = {{0, 0}, {1, 2}},
plot = "starting..."
},
Monitor[
Do[
Pause[0.5];
plot = ListLinePlot[dataList++, PlotRange -> {0, n + 2}],
{i, 1, n}
],
plot
];
plot
];
Do you know mathematica.stackexchange.com? You'll get much more answers for Mathematica specific questions there...

NMinimize eats all memory b/c of unnecessary symbolic work

The following code is a naive way to find the least number whose square has n divisors (the minimum should be its log and the x_i the powers in its prime factorization). If I look at the case n=2000 and use ten variables instead of twenty, this uses somewhere around 600MB of memory. With the value of n I'm actually trying to find the answer for, I need around 20 variables to be sure of not missing the actual solution, and it quickly uses up all available memory and then thrashes swap.
n=8*10^6;
a = Table[N[Log[Prime[i]]], {i, 20}];
b = Table[Subscript[x, i], {i, 20}];
cond = Fold[And, Product[2 Subscript[x, i] + 1, {i, 20}] > n,
Table[Subscript[x, i] >= 0, {i, 20}]] && b \[Element] Integers;
NMinimize[{a.b, cond}, b, MaxIterations -> 1000]
It turns out that the problem isn't related to integer programming etc at all (removing the restriction to the integers doesn't help).
My best guess is that the problem is that Mathematica is wasting all that memory expanding Product[2 Subscript[x, i] + 1, {i, 20}]. If I replace the product with just Product[Subscript[x, i],{i,20}] and change the constraints to be >= 1 rather than 0 I get results without a hassle and without the kernel using more than 50MB of memory. (Though that preserves the inequality constraint and doesn't change the task of minimizing the objective function, it does mess up the integrality requirement- I get even results, which correspond to half-integers in the actual problem.)
One person on StackOverflow had a similar problem; in their case, they had an objective function which was getting evaluated symbolically at a huge cost. They were able to remedy it by making the function only accept numeric input, effectively hiding it from Mathematica's "I have the Expand[] hammer, and everything looks like a nail" tendency. But you can't hide the constraint behind such a function (Mathematica will complain it's an invalid constraint).
Any thoughts on how to fix this?
Edit: I know the correct answer- after my Mathematica code didn't work I used AMPL and a dedicated MINLP solver to get it (quite quickly too). I just want to know how I can ever hope to be able to use Mathematica's built-in nonlinear optimization features in the future despite the crazy things it seems to do with my constraints when I enter them in the only way I know how.
Can inhibit that condition from doing anything unless inputs are numeric, as below.
n = 8*10^6;
nvars = 20;
a = Table[N[Log[Prime[i]]], {i, nvars}];
b = Table[Subscript[x, i], {i, nvars}];
c1[xx : {_?NumericQ ..}] := Times ## (2 xx + 1);
c2 = Map[# >= 0 &, b];
c3 = b \[Element] Integers;
cond = Join[{c1[b] > n}, c2, {c3}];
In[29]:= Timing[NMinimize[{a.b, cond}, b, MaxIterations -> 400]]
Out[29]= {43.82100000000008, {36.77416664719056, {Subscript[x, 1] ->
3, Subscript[x, 2] -> 3, Subscript[x, 3] -> 2,
Subscript[x, 4] -> 2, Subscript[x, 5] -> 1, Subscript[x, 6] -> 1,
Subscript[x, 7] -> 1, Subscript[x, 8] -> 1, Subscript[x, 9] -> 1,
Subscript[x, 10] -> 1, Subscript[x, 11] -> 1,
Subscript[x, 12] -> 1, Subscript[x, 13] -> 0,
Subscript[x, 14] -> 0, Subscript[x, 15] -> 0,
Subscript[x, 16] -> 0, Subscript[x, 17] -> 0,
Subscript[x, 18] -> 0, Subscript[x, 19] -> 0,
Subscript[x, 20] -> 0}}}
---edit---
Thought I would point out that this can be set up as an integer linear programming problem. We use 0-1 variables for all possible combinations of primes and powers.
We can limit the number of primes using the fact that the solution cannot involve more primes than the minimum needed assuming all are raised to the first power. The objective is then minimal if they are consecutive starting at 2.
We will assume the max exponent is no more than 20. There is probably a convenient way to show this but it has not come to mind as yet.
The objective and constraints, in this formulation, are as below. We get a fully linear problem by taking logs of the divisor sigma equation.
n = 8*10^6;
nprimes = Ceiling[Log[2, n]];
maxexpon = 20;
vars = Array[x, {maxexpon, nprimes}];
fvars = Flatten[vars];
c1 = Map[0 <= # <= 1 &, fvars];
c2 = {Element[fvars, Integers]};
c3 = Thread[Total[vars] <= 1];
c4 = {Total[N[Log[2*Range[maxexpon] + 1]].vars] >= N#Log[n]};
constraints = Join[c1, c2, c3, c4];
obj = Range[maxexpon].vars.N[Log[Prime[Range[nprimes]]]];
Timing[{min, vals} = NMinimize[{obj, constraints}, fvars];]
Out[118]= {5.521999999999991, Null}
Pick[fvars, fvars /. vals, 1] /. x[j_, k_] :> {Prime[k], j}
Out[119]= {{11, 1}, {13, 1}, {17, 1}, {19, 1}, {23, 1}, {29, 1}, {31,
1}, {37, 1}, {5, 2}, {7, 2}, {2, 3}, {3, 3}}
This approach handles n=10^10 is around 23 seconds.
---end edit ---
Daniel Lichtblau
You can try this code instead:
Catch[Do[If[DivisorSigma[0, k^2] > 2000, Throw[k]], {k, 1000000}]]
which returns 180180.
ADDITION:
Catch[Do[If[Times##(2 FactorInteger[k][[All, 2]] + 1) > 2000, Throw[k]], {k, 1000000}]]
Seems to work faster.
ADDITION 2:
Behold for this ultra-improved version (but not 100% proved):
MinSquareWithDivisors[n_] :=
Min#Select[
Product[Prime[k]^#[[k]], {k, 1, Length[#]}] & /#
Flatten[IntegerPartitions /# Range[Ceiling[Log[2, n]]], 1],
DivisorSigma[0, #^2] > n &]
MinSquareWithDivisors[2000000000] gives 2768774904222066200260800 in ~4 seconds
Explanation:
First of all one needs to prove that the sum of the prime's exponents in this minimum number is at most Log[2, n]. I haven't found a proof yet, but it might be related to the ratio between successive primes.
Flatten[IntegerPartitions /# Range[Ceiling[Log[2, n]]], 1] gives you all the lists with Total <= Log[2, n], conveniently sorted from large to small.
Product[Prime[k]^#[[k]], {k, 1, Length[#]}] & use them as prime's exponents to create integers.
Min#Select[..., DivisorSigma[0, #^2] > n &] choose the minimal of them that agrees with the original condition.

Multiple Background Subregions in Mathematica Grid

I can`t figure out how to define several subregions with different color background as in the below.
Any Idea ?
Many thanks,
LA
Grid[Table["g", {4}, {7}],
Background -> {None, None, {{{1, 3}, {1, 3}} -> LightRed}}]
Just as a side note, a usual requirement is to specify background colors depending on values.
For that you can do:
k = Table[RandomInteger[{1, 2}], {4}, {7}];
Grid[k,
Background ->
{None, None,
Join[
Position[k, 1] /. {x_, y_} -> ({x, y} -> LightRed),
Position[k, 2] /. {x_, y_} -> ({x, y} -> LightBlue)]
}]
Edit
If you don't know a priori the range of values, you may try something like:
k = Table[RandomInteger[{1, 20}], {4}, {7}];
Grid[k,
Frame -> All,
ItemStyle -> Directive[FontSize -> 16],
Background ->
{None, None,
Flatten#Array[List[##] ->
ColorData["Rainbow"][(k[[##]] - Min#k) / Max#k] &,
Dimensions#k]
}
]
Simply list the regions and colors as you already have the first one:
Grid[Table["g", {4}, {7}],
Background -> {None, None, {
{{1, 3}, {1, 3}} -> LightRed,
{{3, 4}, {4, 7}} -> LightBlue
} } ]