Creating random coefficients for linear equations in mathematica - random

Is there a way to assign a random value to p1, p2, p3 and p4 for the following equation?
p1 y1 + p2 y2 + p3 y3 = p4
given that y1, y2 and y3 are variables to be solved.

The easiest(?) way is to Thread a list of random values over a replacement rule:
For example:
p1 y1 + p2 y2 + p3 y3 == p4 /. Thread[{p1, p2, p3, p4} -> RandomReal[{0, 1}, 4]]
(* 0.345963 y1 + 0.333069 y2 + 0.565556 y3 == 0.643419 *)
Or, inspired by Leonid, you can use Alternatives and pattern matching:
p1 y1 + p2 y2 + p3 y3 == p4 /. p1 | p2 | p3 | p4 :> RandomReal[]
Just for fun, here's one more, similar solution:
p1 y1 + p2 y2 + p3 y3 == p4 /. s_Symbol :>
RandomReal[]/;StringMatchQ[SymbolName[s], "p"~~DigitCharacter]
Where you could replace DigitCharacter with NumberString if you want it to match more than just p0, p1, ..., p9. Of course, for large expressions, the above won't be particularly efficient...

The other answers are good, but if you do a lot of this sort of thing, I recommend naming your variables and coefficients in a more systematic way. This will not only allow you to write a much simpler rule, it will also make for much simpler changes when it's time to go from 3 equations to 4. For example:
In[1]:= vars = Array[y, 3]
Out[1]= {y[1], y[2], y[3]}
In[2]:= coeffs = Array[p, 4]
Out[2]= {p[1], p[2], p[3], p[4]}
You can be a little fancy when you make your equation:
In[3]:= vars . Most[coeffs] == Last[coeffs]
Out[3]= p[1] y[1] + p[2] y[2] + p[3] y[3] == p[4]
Substituting random numbers for the coefficients is now one one very basic rule:
In[4]:= sub = eqn /. p[_] :> RandomReal[]
Out[4]= 0.281517 y[1] + 0.089162 y[2] + 0.0860836 y[3] == 0.915208
The rule at the end could also be written _p :> RandomReal[], if you prefer. You don't have to type much to solve it, either.
In[5]:= Reduce[sub]
Out[5]= y[1] == 3.25099 - 0.31672 y[2] - 0.305785 y[3]
As Andrew Walker said, you use Reduce to find all the solutions, instead of just some of them. You can wrap this up in a function which paramerizes the number of variables like so:
In[6]:= reduceRandomEquation[n_Integer] :=
With[{vars = Array[y, n], coeffs = Array[p, n+1]},
Reduce[vars . Most[coeffs]]
In[7]:= reduceRandomEquation[4]
Out[7]= y[1] == 2.13547 - 0.532422 y[2] - 0.124029 y[3] - 2.48944 y[4]

If you need solutions with values substituted in, one possible way to do this is:
f[y1_, y2_, y3_] := p1 y1 + p2 y2 + p3 y3 - p4
g = f[y1, y2, y3] /. p1 -> RandomReal[] /. p2 -> RandomReal[] /.
p3 -> RandomReal[] /. p4 -> RandomReal[]
Reduce[g == 0, {y1}]
Reduce[g == 0, {y2}]
Reduce[g == 0, {y3}]
If all you need is the solution to the equations:
f[y1_, y2_, y3_] := p1 y1 + p2 y2 + p3 y3 - p4
g = f[y1, y2, y3]
Solve[g == 0, {y1}]
Solve[g == 0, {y2}]
Solve[g == 0, {y3}]

If you can live without the symbolic coefficient names p1 et al, then you might generate as below. We take a variable list, and number of equations, and a range for the coefficients and rhs vector.
In[80]:= randomLinearEquations[vars_, n_, crange_] :=
Thread[RandomReal[crange, {n, Length[vars]}].vars ==
RandomReal[crange, n]]
In[81]:= randomLinearEquations[{x, y, z}, 2, {-10, 10}]
Out[81]= {7.72377 x - 4.18397 y - 4.58168 z == -7.78991, -1.13697 x +
5.67126 y + 7.47534 z == -6.11561}
It is straightforward to obtain variants such as integer coefficients, different ranges for matrix and rhs, etc.
Daniel Lichtblau

Another way:
dim = 3;
eq = Array[p, dim].Array[y, dim] == p[dim + 1];
Evaluate#Array[p, dim + 1] = RandomInteger[10, dim + 1]
Solve[eq, Array[y, dim]]

Related

how do I solve a double integral in Mathematica?

I am very new to Mathematica, and I am trying to solve the following problem.
I have a cubic equation of the form Z = aZ^3 + bZ^2 + a + b. The first thing I want to do is to get a function that solves this analytically for Z and chooses the minimal positive root for that, as a function of a and b.
I thought that in order to get the root I could use:
Z = Solve[z == az^3 + bz^2 + a + b, z];
It seems like I am not quite getting the roots, as I would expect using the general cubic equation solution formula.
I want to integrate the minimal positive root of Z over a and b (again, preferably analytically) from 0 to 1 for a and for a to 1 for b.
I tried
Y = Integrate[Z, {a, 0, 1}, {b, a, 1}];
and that does not seem to give any formula or numerical value, but just returns an integral. (Notice I am not even sure how to pick the minimal positive root, but I am playing around with Mathematica to try to figure it out.)
Any ideas on how to do this?
Spaces between a or b and z are important. You can get the roots by:
sol = z /. Solve[z == a z^3 + b z^2 + a + b, z]
However, are you sure this expression has a solution as you expect? For a=0.5 and b=0.5, the only real root is negative.
sol /. {a->0.5, b->0.5}
{-2.26953,0.634765-0.691601 I,0.634765+0.691601 I}
sol = z /. Solve[z == a z^3 + b z^2 + a + b, z];
zz[a0_ /; NumericQ[a0], b0_ /; NumericQ[b0]] :=
Min[Select[ sol /. {a -> a0, b -> b0} ,
Element[#, Reals] && # > 0 & ]]
This returns -infinty when there are no solutions. As sirintinga noted your example integration limits are not valid..
RegionPlot[NumericQ[zz[a, b] ] , {a, -1, .5}, {b, -.5, 1}]
but you can numerically integrate if you have a valid region..
NIntegrate[zz[a, b], {a, -.5, -.2}, {b, .8, .9}] ->> 0.0370076
Edit ---
there is a bug above Select in Reals is throwin away real solutions with an infinitesimal complex part.. fix as:..
zz[a0_ /; NumericQ[a0], b0_ /; NumericQ[b0]] :=
Min[Select[ Chop[ sol /. {a -> a0, b -> b0} ],
Element[#, Reals] && # > 0 & ]]
Edit2, a cleaner approach if you dont find Chop satisfyting..
zz[a0_ /; NumericQ[a0], b0_ /; NumericQ[b0]] :=
Module[{z, a, b},
Min[z /. Solve[
Reduce[(z > 0 && z == a z^3 + b z^2 + a + b /.
{ a -> a0, b -> b0}), {z}, Reals]]]]
RegionPlot[NumericQ[zz[a, b] ] , {a, -2, 2}, {b, -2, 2}]
NIntegrate[zz[a, b], {a, 0, .5}, {b, 0, .5 - a}] -> 0.0491321

Creating a matrix from the coefficients of equations

Given the equations
eqn1 = 5 x1 + 2 x2 + 3 x3 == 8
eqn2 = 4 x1 + 7 x2 + 9 x3 == 5
eqn3 = 6 x1 + x2 + 9 x3 == 2
how do I extract the coefficients of x1, x2, x3 to form a matrix?
I tried using CoefficientArrays but the output was given as a SparseArray.
Try Normal
(Normal[CoefficientArrays[{eqn1, eqn2, eqn3}, {x1, x2, x3}]][[2]]) // MatrixForm
I am not fond of Normal
Coefficient[# /. Equal[e_, _] -> e, {x1, x2, x3}] & /# {eqn1, eqn2, eqn3}
Shorter but not as clear:
Coefficient[First##, {x1, x2, x3}] & /# {eqn1, eqn2, eqn3}

How can I plot a function defined on the unit simplex in Mathematica?

I am trying to plot a function in Mathematica that is defined over the unit simplex. To take a random example, suppose I want to plot sin(x1*x2*x3) over all x1, x2, x3 such that x1, x2, x3 >= 0 and x1 + x2 + x3 = 1.
Is there a neat way of doing so, other than the obvious way of writing something like
Plot3D[If[x+y<=1,Sin[x y(1-x-y)]],{x,0,1},{y,0,1}]
?
What I want, ideally, is a way of plotting only over the simplex. I found the website http://octavia.zoology.washington.edu/Mathematica/ which has an old package, but it doesn't work on my up-to-date version of Mathematica.
If you want to get symmetric looking plots like in that package you linked, you need to figure out rotation matrix that puts the simplex into x/y plane. You can use this function below. It's kind of long because I left in the calculations to figure out simplex centering. Ironically, transformation for 4d simplex plot is much simpler. Modify e variable to get different margin
simplexPlot[func_, plotFunc_] :=
Module[{A, B, p2r, r2p, p1, p2, p3, e, x1, x2, w, h, marg, y1, y2,
valid},
A = Sqrt[2/3] {Cos[#], Sin[#], Sqrt[1/2]} & /#
Table[Pi/2 + 2 Pi/3 + 2 k Pi/3, {k, 0, 2}] // Transpose;
B = Inverse[A];
(* map 3d probability vector into 2d vector *)
p2r[{x_, y_, z_}] := Most[A.{x, y, z}];
(* map 2d vector in 3d probability vector *)
r2p[{u_, v_}] := B.{u, v, Sqrt[1/3]};
(* Bounds to center the simplex *)
{p1, p2, p3} = Transpose[A];
(* extra padding to use *)
e = 1/20;
x1 = First[p1] - e/2;
x2 = First[p2] + e/2;
w = x2 - x1;
h = p3[[2]] - p2[[2]];
marg = (w - h + e)/2;
y1 = p2[[2]] - marg;
y2 = p3[[2]] + marg;
valid =
Function[{x, y}, Min[r2p[{x, y}]] >= 0 && Max[r2p[{x, y}]] <= 1];
plotFunc[func ## r2p[{x, y}], {x, x1, x2}, {y, y1, y2},
RegionFunction -> valid]
]
Here's how to use it
simplexPlot[Sin[#1 #2 #3] &, Plot3D]
(source: yaroslavvb.com)
simplexPlot[Sin[#1 #2 #3] &, DensityPlot]
(source: yaroslavvb.com)
If you want to see domain in the original coordinate system, you could rotate the plot back to the simplex
t = AffineTransform[{{{-(1/Sqrt[2]), -(1/Sqrt[6]), 1/Sqrt[3]}, {1/
Sqrt[2], -(1/Sqrt[6]), 1/Sqrt[3]}, {0, Sqrt[2/3], 1/Sqrt[
3]}}, {1/3, 1/3, 1/3}}];
graphics = simplexPlot[5 Sin[#1 #2 #3] &, Plot3D];
shape = Cases[graphics, _GraphicsComplex];
Graphics3D[{Opacity[.5], GeometricTransformation[shape, t]},
Axes -> True]
(source: yaroslavvb.com)
Here's another simplex plot, using traditional 3d axes from here and MeshFunctions->{#3&}, complete code here
(source: yaroslavvb.com)
Try:
Plot3D[Sin[x y (1 - x - y)], {x, 0, 1}, {y, 0, 1 - x}]
But you can also use Piecewise and RegionFunction:
Plot3D[Piecewise[{{Sin[x y (1 - x - y)],
x >= 0 && y >= 0 && x + y <= 1}}], {x, 0, 1}, {y, 0, 1},
RegionFunction -> Function[{x, y}, x + y <= 1]]

how to solve for the unknowns given two equating polynomials in mathematica

I have, for example, the following polynomials to be equated, and I need to determine the unknowns c1, c2, c3, respectively. How can I do this automatically in mma, especially when there are many terms involved?
x+2*x^3+4*x^5==(c1+c2)*(x+2*c2*x^3)+(4-c1)*c3*x^5
Many thanks.
Edit: ideally, I want to equate the coefficients of left and right for the terms with equal exponents in x. Then solve this system of equations.
If this has to be true for all x, you could use SolveAlways (not tested)
SolveAlways[x+2*x^3+4*x^5==(c1+c2)*(x+2*c2*x^3)+(4-c1)*c3*x^5, x]
Try:
p1 = x + 2*x^3 + 4*x^5;
p2 = (c1 + c2)*(x + 2*c2*x^3) + (4 - c1)*c3*x^5;
Solve[CoefficientList[p2, x] == CoefficientList[p1, x], {c1, c2, c3}]
Out
{{c1 -> 0, c2 -> 1, c3 -> 1}}
This should do what you want even in more complicated situations.
eq = x + 2*x^3 + 4*x^5 == (c1 + c2)*(x + 2*c2*x^3) + (4 - c1)*c3*x^5;
list = CoefficientList[eq /. Equal[k__, l__] -> Plus[k, -l], x];
vars = Variables#list;
Solve[list == Table[0, {i, First#Dimensions#list}], vars]
Out[1] := {{c1 -> 0, c2 -> 1, c3 -> 1}}

How to generate a list of sets of inequalities in mathematica

I want to do the following in Mma. Suppose I have three expressions, x1, 3 x1-x2, x2-x1 where 0<=x1,x2<=1). I want to have another one which specifies the largest among the three is at least twice of the smallest. So there are some permutation of the three in terms of their order:
x1<=3 x1-x2<=x2-x1 && 2 x1<=x2-x1
3 x1-x2<=x1<=x2-x1 && 2 (3 x1-x2)<=x2-x1
....
with the rest 4 similar conditions.
How do I form these conditions automatically (together with 0<=x1,x2<=1), and then feed them into Reduce one-by-one, and solve for x2 in terms of x1?
Many thanks!
eqs = {x1, 3 x1 - x2, x2 - x1};
Reduce[Max[eqs] >= 2 Min[eqs], {x1, x2}, Reals]
If you want to do comparisons with second-largest or third largest/smallest then can use RankedMax
As far as solving it for x2 -- there are many different values of x2 corresponding to each x1 so you can't solve it in the conventional sense, you can see it from RegionPlot
RegionPlot[Max[eqs] >= 2 Min[eqs], {x1, 0, 1}, {x2, 0, 1}, PlotPoints -> 100]
Use Max and Min and specify x2 before x1 in the variable list, as follows
In[1]:= Reduce[
Max[x1, 3 x1 - x2, x2 - x1] >= 2 Min[x1, 3 x1 - x2, x2 - x1] &&
0 <= x1 && x2 <= 1,
{x2, x1}]

Resources