2
$\begingroup$

I'm trying to plot the following table of plots.
The number of plots is very very big (236 196 plots) so it would take very long time to run.
I don't know when the running will end.
Is there any way to plot all cases easier or faster?

f1[a1_, a2_, a3_, a4_, a5_, a6_, b1_, b2_, b3_, b4_, b5_, b6_, 
   d_] := -(((a5 + a2 d - a5 d) (b4 + b1 d - b4 d) - (a4 + a1 d - 
       a4 d) (b5 + b2 d - b5 d) )/(-(a6 + a3 d - a6 d) (b5 + b2 d - 
       b5 d) + (a5 + a2 d - a5 d) (b6 + b3 d - b6 d)));
f2[a1_, a2_, a3_, a4_, a5_, a6_, b1_, b2_, b3_, b4_, b5_, b6_, 
   d_] := (a4 b6 - a6 (-1 + d) (b4 (-1 + d) - b1 d) + 
    d (a4 b3 - a3 b4 + a1 b6 - 2 a4 b6 + 
       a3 (-b1 + b4) d + (a1 - a4) (b3 - b6) d)) /(
  a6 (-1 + d) (b5 (-1 + d) - b2 d) - 
   a5 (-1 + d) (b6 (-1 + d) - b3 d) + 
   d (a2 b6 (-1 + d) - a2 b3 d + a3 (b5 + b2 d - b5 d)));


Table[Quiet@
     Plot[{f1[a1, a2, a3, a4, a5, a6, b1, b2, b3, b4, b5, b6, d], 
       f2[a1, a2, a3, a4, a5, a6, b1, b2, b3, b4, b5, b6, d], 1}, {d, 
       0, 1}, PlotLabel -> {Style[
         StringForm[
          "a1= `` a2= `` a3= `` a4= `` a5= `` a6= ``b1= `` b2= `` b3= \
`` b4= `` b5= `` b6= ``", a1, a2, a3, a4, a5, a6, b1, b2, b3, b4, b5, 
          b6], FontFamily -> "Times", FontSize -> 30, Blue, Bold], 
        "\n", 
        TraditionalForm[
         Style[StringForm[ "A = `` B= ``", 
           FullSimplify[
            f1[a1, a2, a3, a4, a5, a6, b1, b2, b3, b4, b5, b6, d]], 
           FullSimplify[
            f2[a1, a2, a3, a4, a5, a6, b1, b2, b3, b4, b5, b6, d]]], 
          FontFamily -> "Times", FontSize -> 30, Blue, Bold]] },
      ImageSize -> 1000,
      PlotStyle -> {Directive[Red, Thick], Directive[Blue, Thick], 
        Directive[Blue, Dashed]},
      Ticks -> Automatic,
      TicksStyle -> Directive[Black, Bold, 20],
      GridLines -> Automatic,
      GridLinesStyle -> LightGray
      ]
    , {a1, {0, 1}}, {a2, {-1, 0, 1}}, {a3, {-1, 0, 1}}, {a4, {0, 
      1}}, {a5, {-1, 0, 1}}, {a6, {-1, 0, 1}},
        {b1, {0, 1}}, {b2, {-1, 0, 1}}, {b3, {-1, 0, 1}}, {b4, {0, 
      1}}, {b5, {-1, 0, 1}}, {b6, {-1, 0, 1}}] // Flatten // 
  Partition[#, 2] & // Grid
$\endgroup$
10
  • 4
    $\begingroup$ Your table would actually generate 104,976 plots. Plots are used to present data for human visual consumption, but I cannot see a situation in which a human viewer could sift through that many plots and make any sense of them. Simply put, I don't see the point of what you are trying to do. Why do you need to plot that many plots? What do you want to do with them, since you pretty clearly won't be looking at them one by one? $\endgroup$
    – MarcoB
    Dec 9 '20 at 15:43
  • $\begingroup$ I will look at them one by one for my project $\endgroup$
    – emnha
    Dec 9 '20 at 15:49
  • 3
    $\begingroup$ What are you looking for though? If you describe the actual problem you are trying to solve, then perhaps we could build a way to have Mathematica recognize and select what you need, instead of having you look at plots for hours. $\endgroup$
    – MarcoB
    Dec 9 '20 at 15:51
  • $\begingroup$ Consider also that each plot won't take long itself, but you included TWO FullSimplify calls in each of them. Those will take a long time compared to plotting and they are the main bottleneck in your code. Can you do without them? $\endgroup$
    – MarcoB
    Dec 9 '20 at 15:54
  • $\begingroup$ I think I can do without that. I want to plot and see each case. One thing that can be simplified is that the plot where the function f1 is less than 0 for ALL d values should be omitted. Is there any way to do that? $\endgroup$
    – emnha
    Dec 9 '20 at 16:17
4
$\begingroup$

It takes me about 1 minute to plot 2k of them without FullSimplify and 2 minutes with (50 - 100 minutes total). However, 100k plots takes a lot of memory. I'm using 1 GB just for those 2k. Mathematica will also take ages to format those for display, so don't try to display all 100k at once. I don't see the point, though: $104,976 \text{ plots} \cdot \frac{1 \text{ minute}}{6 \text{ plots}} \cdot \frac{1 \text{ hour}}{60 \text{ minutes}} \cdot \frac{1 \text{ day}}{24 \text{ hours}} = 12.15 \text{ days}$ (no sleeping!) And can you really say anything insightful about a graph after only looking at it for 10 seconds?

Computation should make your life easier, not harder. In the end, no one else will ever see all these plots. It seems to me that your actual problem (X) is that you need to compare or summarize the results of these graphs in some way, and you think the best way (Y) is to generate all of them and sort or analyze them by hand somehow (see XY Problem). If we knew what the end result was, we might be able to help you skip straight to the final result and literally save you weeks of poring over graphs.

For example you generate a huge number of plots that always reduce to Indeterminate, ComplexInfinity, 1, 0, -1, etc. Do you really need to see a plot of those?

Here's where I would start in order to at least start to get a grip on what's going on.

tup = Tuples[{
   {0, 1}, {-1, 0, 1}, {-1, 0, 1}, {0, 1}, {-1, 0, 1}, {-1, 0, 1}, 
   {0, 1}, {-1, 0, 1}, {-1, 0, 1}, {0, 1}, {-1, 0, 1}, {-1, 0, 1}
}];
resultsf1 = Quiet@FullSimplify[f1[##, d]] & @@@ tup;
resultsf2 = Quiet@FullSimplify[f2[##, d]] & @@@ tup;
keyvalsf1 = {Keys[#], Values[#]}\[Transpose] &@Counts[resultsf1];
keyvalsf2 = {Keys[#], Values[#]}\[Transpose] &@Counts[resultsf2];
cf1 = Cases[
  keyvalsf1, 
  {ComplexInfinity | Indeterminate | _?NumberQ, _}
]
cf2 = Cases[
  keyvalsf2, 
  {ComplexInfinity | Indeterminate | _?NumberQ, _}
]
Total[cf1[[All, 2]]]
Total[cf2[[All, 2]]]
Length[keyvalsf1]
Length[keyvalsf2]

$\left( \begin{array}{cc} \text{Indeterminate} & 2253 \\ 0 & 12322 \\ \text{ComplexInfinity} & 5800 \\ -1 & 3957 \\ -\frac{1}{2} & 576 \\ 1 & 3956 \\ \frac{1}{2} & 576 \\ 2 & 200 \\ -2 & 200 \\ \end{array} \right)$

$\left( \begin{array}{cc} \text{Indeterminate} & 2204 \\ 0 & 12333 \\ \text{ComplexInfinity} & 5836 \\ 1 & 3959 \\ \frac{1}{2} & 576 \\ -1 & 3956 \\ -\frac{1}{2} & 576 \\ 2 & 200 \\ -2 & 200 \\ \end{array} \right)$

29840

29840

2977

3151

I have Tuples generate every possible pairing of values. This gives the same result as your Table but doesn't require Flatten and it's easier to go back and compare the final result with the arguments in tup. I think you should be a bit shocked by some of those numbers. You can see that of the 100k plots, about 30% will either have a flat line or display nothing for one of f1 or f2. Since those 30k graphs only have 1 of 9 possible outcomes, a lot of computation has been done to generate 4 bits of information per graph.

What's worse are those last 2 numbers. They're telling us that there are only about 3k unique graphs for each of f1 and f2. So you would view at least 98k graphs and not learn anything. We can also find out how many times f1 and f2 will produce the same boring graph:

sel = Select[{resultsf1, resultsf2}\[Transpose], #[[1]] === #[[2]] &];
Cases[sel, 
  {ComplexInfinity | Indeterminate | _?NumberQ, 
   ComplexInfinity | Indeterminate | _?NumberQ}] // Length

13066

or in how many cases the graph will be boring for both functions but not necessarily identical:

Cases[
  {resultsf1, resultsf2}\[Transpose], 
  {
     ComplexInfinity |  Indeterminate | _?NumberQ, 
     ComplexInfinity | Indeterminate | _?NumberQ
}] // Length

21600

If you look at the data stored in keyvalsf1/2, you'll be able to see what the unique functions are and how many times each one is repeated. If you wanted, it should also be possible to extract the arguments from tup that correspond to particular solutions, the problem is I'm not sure what you do want.

Finally, if you're really dead-set on analyzing all those graphs and don't want anyone to tell you it's not efficient, here's how you can generate groups of 2k at a time. It's fast enough that you could always start the next group while you're viewing the first 2k and it'll finish before you do.

f1[a1_, a2_, a3_, a4_, a5_, a6_, b1_, b2_, b3_, b4_, b5_, b6_, 
   d_] := -(((a5 + a2 d - a5 d) (b4 + b1 d - b4 d) - (a4 + a1 d - 
          a4 d) (b5 + b2 d - b5 d))/(-(a6 + a3 d - a6 d) (b5 + b2 d - 
          b5 d) + (a5 + a2 d - a5 d) (b6 + b3 d - b6 d)));
f2[a1_, a2_, a3_, a4_, a5_, a6_, b1_, b2_, b3_, b4_, b5_, b6_, 
   d_] := (a4 b6 - a6 (-1 + d) (b4 (-1 + d) - b1 d) + 
     d (a4 b3 - a3 b4 + a1 b6 - 2 a4 b6 + 
        a3 (-b1 + b4) d + (a1 - a4) (b3 - b6) d))/(a6 (-1 + 
        d) (b5 (-1 + d) - b2 d) - a5 (-1 + d) (b6 (-1 + d) - b3 d) + 
     d (a2 b6 (-1 + d) - a2 b3 d + a3 (b5 + b2 d - b5 d)));

tup = Tuples[{
  {0, 1}, {-1, 0, 1}, {-1, 0, 1}, {0, 1}, {-1, 0, 1}, {-1, 0, 1}, 
  {0, 1}, {-1, 0, 1}, {-1, 0, 1}, {0, 1}, {-1, 0, 1}, {-1, 0, 1}
}];

Partition[
  Quiet@Plot[
    {f1[##, d], f2[##, d], 1}, 
    {d, 0, 1}, 
    PlotLabel -> {
      Style[
        StringForm[
          "a1= `` a2= `` a3= `` a4= `` a5= `` a6= ``b1= `` b2= `` b3= `` b4= `` b5= `` b6= ``", ##], 
        FontFamily -> "Times", 
        FontSize -> 30, 
        Blue,
        Bold], "\n", 
        TraditionalForm[
         Style[StringForm["A = `` B= ``", FullSimplify[f1[##, d]], 
           FullSimplify[f2[##, d]]], FontFamily -> "Times", 
          FontSize -> 30, Blue, Bold]]}, ImageSize -> 1000, 
    PlotStyle -> {Directive[Red, Thick], Directive[Blue, Thick], Directive[Blue, Dashed]}, 
    Ticks -> Automatic, 
    TicksStyle -> Directive[Black, Bold, 20], 
    GridLines -> Automatic, 
    GridLinesStyle -> LightGray
  ] & @@@ tup[[1 ;; 2000]],
2] // Grid

EDIT:

If there's no advantage to looking at duplicates, you can pare the possibilities down quite a bit and programmatically determine their ranges over $0 \leq d \leq 1$. I don't know if you can combine f1 and f2, but perhaps this will give you some ideas about how to analyze your results. If we're only looking at perfectly unique functions that are non-negative for at least one point in the domain, we can get it down to 3203 functions.

Re-using my first code block plus your definitions of f1 and f2:

keyvals = {Keys[#], Values[#]}\[Transpose] &@Counts[Join[resultsf1, resultsf2]];
ranges = Quiet@{
  #, 
  Minimize[{#, 0 <= d <= 1}, d][[1]], 
  Maximize[{#, 0 <= d <= 1}, d][[1]]
 } & /@ Cases[keyvals, {Except[Indeterminate | ComplexInfinity], _}][[All, 1]];
sel = Select[ranges, #[[3]] >= 0 &];
sel[[1;;10]]

$\left( \begin{array}{ccc} 0 & 0 & 0 \\ 1 & 1 & 1 \\ \frac{1}{2} & \frac{1}{2} & \frac{1}{2} \\ \frac{d-1}{d} & -\infty & 0 \\ d-1 & -1 & 0 \\ \frac{1}{2-d}-1 & -\frac{1}{2} & 0 \\ \frac{d-1}{2 d-1} & -\infty & \infty \\ \frac{d-1}{3 d-2} & -\infty & \infty \\ \frac{d-1}{2 d} & -\infty & 0 \\ \frac{d-1}{d+1} & -1 & 0 \\ \end{array} \right)$

This table gives the function, then the minimum, then the maximum. I think that determining the maximum and minimum programmatically is actually better. A plot will not specifically show you that the value goes to $\pm \infty$, you would have to infer it. Plus, this way you can get exact values for the max and min. And of course, you can still plot all 3203 unique functions if you like. At least it should take you 33x less time to analyze all of those graphs than the 100k we started with.

But I hope that you can see that if a question can be well-posed in a computational or mathematical sense, such as "what is the range of a function?", you can often save a lot of time. If you can specify what other things you want to measure, they can probably be automated as well. If it's just a qualitative measure of some kind, then I guess you're stuck looking at the graphs, but hopefully there will be fewer to look at now.

$\endgroup$
10
  • $\begingroup$ Thanks but the code doesn't work for me. I understand that it's not efficient but what can I do? What I need is to plot them and look at the range of each plot. Also look at how each curve looks. $\endgroup$
    – emnha
    Dec 9 '20 at 21:39
  • $\begingroup$ @anhnha Which part isn't working? The plotting seems to work fine for me, but make sure to run your definitions for f1 and f2 first as well as my definition of tup. I guess I should edit that so that it can more easily be copied-and-pasted. The range is something that is easily found computationally rather than writing down 100k ranges. "How each curve looks" what does that mean? Good/bad/ugly? Or is there some quantitative definition? At the very least, would it be ok to pare them down to the ~6k that I identified as being unique? Does looking at the duplicates provide any advantage? $\endgroup$
    – MassDefect
    Dec 9 '20 at 21:53
  • $\begingroup$ I ran but it generated empty plots. I'm running it again but still running. I have to look at each curve, see the range of expression with d not quantitative definition. 6k seems OK. I did similar thing for 2k and checked one by one. Duplicate expression would not provide any advantage. $\endgroup$
    – emnha
    Dec 9 '20 at 22:03
  • $\begingroup$ @anhnha I added some further comments that I think might allow you to get down to ~3200 functions to look at. I've also shown one way that I think you could extract the minimum and maximum over your given domain. $\endgroup$
    – MassDefect
    Dec 9 '20 at 23:57
  • $\begingroup$ Thanks. I think you misunderstood the condition that #[[3]] >= 0. The selected one can be negative at some values of d but it shouldn't be negative for all values of d. $\endgroup$
    – emnha
    Dec 10 '20 at 1:43
2
$\begingroup$
  • Generate all values of $a_1...a_6$ and $b_1...b_6$, then plug them in to f1 to obtain all possible expressions as a function of d only.
abvals = Table[
    {a1, a2, a3, a4, a5, a6, b1, b2, b3, b4, b5, b6, d},
    {a1, {0, 1}}, {a2, {-1, 0, 1}}, {a3, {-1, 0, 1}},
    {a4, {0, 1}}, {a5, {-1, 0, 1}}, {a6, {-1, 0, 1}},
    
    {b1, {0, 1}}, {b2, {-1, 0, 1}}, {b3, {-1, 0, 1}},
    {b4, {0, 1}}, {b5, {-1, 0, 1}}, {b6, {-1, 0, 1}}
    ] // Flatten[#, 11] &;
  • FullSimplify those expressions to reduce them to a simpler "standard format".
simplified = FullSimplify[{#, f1 @@ #} & /@ abvals];

simplified // Dimensions
(* Out: {104976, 2} *)
  • Group the results by the value of the function (i.e. the expression in d), removing those that resulted in Indeterminate or ComplexInfinity; notice the huge reduction in the cases you now have to consider, from 104,976 to 2,982. Still a lot though.
grouped = KeyDrop[{Indeterminate, ComplexInfinity}]@ GroupBy[Last]@ simplified;

grouped // Dimensions
(* Out: {2982} *)
  • Select for further analysis only those expressions that are non-negative (i.e. $\geq0$ for all values of d:
selected = KeySelect[grouped, Simplify[# >= 0, Assumptions -> 0 <= d <= 1] &];

selected // Dimensions
(* Out: 306 *)

Now that you have your expressions boiled down to 306 distinct cases, that is a number fow which you can consider hand-picking or visual analysis or whatever else you need to do with these...

$\endgroup$
1
  • $\begingroup$ The last condition is reversed actually. I want to remove those expressions that are negative for all values of d. So some expressions that are negative for some values of d are still OK. $\endgroup$
    – emnha
    Dec 9 '20 at 21:44

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.