Given the following list:
{a + b, c + d + e, - a + b, a - b, - c - d - e}
I would like to get as a result:
{a + b, a - b, c + d + e}
To clarify: I'd like to transform the first list in such a way that the first term in each element is normalized to a plus sign and throw away any elements that can be obtained from the final result by multiplying with -1.
I have tried Collect[] and FactorTerms[] and some other functions that look remotely like they would be able to do what I need, but they never touch minus signs ....
Any help is greatly appreciated.
Use FactoredTermsList:
In[5]:= FactorTermsList /# {a + b, c + d + e, -a + b,
a - b, -c - d - e}
Out[5]= {{1, a + b}, {1, c + d + e}, {-1, a - b}, {1, a - b}, {-1,
c + d + e}}
In[6]:= DeleteDuplicates[%[[All, 2]]]
Out[6]= {a + b, c + d + e, a - b}
Replace each by its negative if the syntactic sign of the first element is negative. Then take the union. Example:
ll = {a + b, c + d + e, -a + b, a - b, -c - d - e}
Out[444]= {a + b, c + d + e, -a + b, a - b, -c - d - e}
Union[Map[
If[Head[#] === Plus && Head[#[[1]]] === Times &&
NumberQ[#[[1, 1]]] && #[[1, 1]] < 0, Expand[-#], #] &, ll]]
{a - b, a + b, c + d + e}
Daniel Lichtblau
It looks like you want to eliminate the elements that are duplicate modulo an overall sign. At least in this particular case, the following will work:
In[13]:= Union[FullSimplify#Abs[{a + b, c + d + e, -a + b, a - b, -c - d - e}]] /.
Abs[x_] :> x
Out[13]= {a - b, a + b, c + d + e}
If the order of elements in the list matters, you can use DeleteDuplicates in place of Union.
Here's an attempt.
ClearAll[nTerm];
nTerm[t_] := If[MatchQ[t[[1]], Times[-1, _]], -t, t]
is intended to be mapped over a list; takes a single item (of the list) as input, replaces it by its negative if the first element has a negative sign. So nTerm[-a + b + c] gives a - b - c, which is left invariant by nTerm: nTerm[a - b - c] gives back its argument.
Next,
ClearAll[removeElements];
removeElements[lst_] :=
DeleteDuplicates[lst, (#1 \[Equal] #2) || (#1 \[Equal] -#2) &]
takes a list as argument, removes those list elements that might be obtained from another list element by negation: removeElements[{1, 2, 3, -2, a, -a, "GWB", -"GWB"}] gives {1, 2, 3, a, "GWB"} (!). Finally,
ClearAll[processList];
processList[lst_] := removeElements[nTerm /# lst]
applies the whole lot to an input list; thus, li = {a + b, c + d + e, -a + b, a - b, -c - d - e}; processList[li] gives {a + b, c + d + e, a - b}
Related
I'm trying to find the coefficients of a function by minimizing an equation who I know is zero with Mathematica. My code is:
Clear[f];
Clear[g];
Clear[GetGood];
Clear[int];
Clear[xlist];
Xmax = 10;
n = 10;
dx = Xmax/n;
xlist = Table[i*dx, {i, n}];
A = 3.5;
slope = (A + 2)/3;
f[x_, a_, b_, c_, d_, e_] :=a/(1 + b*x + c*x^2 + d*x^3 + e*x^4)^(slope/4 + 2);
g[x_, a_, b_, c_, d_, e_] :=Derivative[1, 0, 0, 0, 0, 0][f][x, a, b, c, d, e];
int[a_?NumericQ, b_?NumericQ, c_?NumericQ, d_?NumericQ, e_?NumericQ] :=
Module[{ans, i},ans = 0;Do[ans =ans + Quiet[NIntegrate[
y^-slope*(f[Sqrt[xlist[[i]]^2 + y^2 + 2*xlist[[i]]*y*m], a, b,
c, d, e] - f[xlist[[i]], a, b, c, d, e]), {m, -1, 1}, {y,
10^-8, \[Infinity]}, MaxRecursion -> 30]], {i, 1,
Length[xlist]}];
ans
];
GetGood[a_?NumericQ, b_?NumericQ, c_?NumericQ, d_?NumericQ,e_?NumericQ] :=
Module[{ans},ans = Abs[Sum[3*f[x, a, b, c, d, e] + x*g[x, a, b, c, d,e],
{x,xlist}]+2*Pi*int[a, b, c, d, e]];
ans
];
NMinimize[{GetGood[a, b, c, d, e], a > 0, b > 0, c > 0, d > 0,
e > 0}, {a, b, c, d, e}]
The error I get after the last line is:
Part::pspec: Part specification i$3002170 is neither an integer nor a list of integers. >>
NIntegrate::inumr: "The integrand (-(1.84529/(1+<<3>>+0.595769 Part[<<2>>]^4)^2.45833)+1.84529/(1+<<18>> Sqrt[Plus[<<3>>]]+<<1>>+<<1>>+0.595769 Plus[<<3>>]^2)^2.45833)/y^1.83333 has evaluated to non-numerical values for all sampling points in the region with boundaries {{-1,1},{\[Infinity],1.*10^-8}}"
Any ideas why I am getting an error?
Thanks
Change your NMinimize to be
NMinimize[{GetGood[a,b,c,d,e],a>0&&b>0&&c>0&&d>0&&e>0}, {a,b,c,d,e}]
to get your constraints to work correctly. Their help page should really show an example of using more than a single constraint. This old page does show an example.
http://reference.wolfram.com/legacy/v5_2/functions/AdvancedDocumentationNMinimize
If you change your int[] to
int[a_?NumericQ, b_?NumericQ, c_?NumericQ, d_?NumericQ, e_?NumericQ] :=
Module[{ans, i}, ans = 0; Do[
Print["First i=", i];
ans = ans + Quiet[NIntegrate[
Print["Second i=", i];
y^-slope*(f[Sqrt[xlist[[i]]^2 + y^2 + 2*xlist[[i]]*y*m], a,b,c,d,e] -
f[xlist[[i]], a,b,c,d,e]), {m,-1,1}, {y,10^-8, \[Infinity]}, MaxRecursion -> 30]],
{i, 1, Length[xlist]}];
ans];
you will see
First i=1
Second i=1
....
First i=10
Second i=i$28850
where the first debug print never says i=i$nnnn but the second debug print does often show that i has been unassigned a value only inside your NIntegrate, not outside it, and only after i has reached a value of 10, the length of your xlist, and at that point you can't subscript by a symbol and you get the error messages you have seen.
Nothing inside your NIntegrate is changing the value of i.
I think you may have stumbled onto a bug where Mathematica is writing over the value of i.
See if you can simplify the code without driving the bug into hiding. If you can make it simpler and still show the problem you might have more likelihood of success in getting Wolfram to admit you have found a bug.
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
Suppose I have this Mathematica code, whose output, a real number, depends on the input, say, x,y,z. How do I make a real-valued function in x,y,z based on the code?
If the code describes a simple relationship among x,y,z, I could define this function directly. The point here is that the given code is a very complicated block (or module).
For example, if the code simply sums x,y,z, I would simply define
f[x_,y_,z_]=x+y+z
What if I have a very complex example, like the one below:
s0[a_, b_, x_] :=
{1, 0, (a + b) x + (1 - a - b)}
s1[a_, b_, c_, d_, p_, q_, n_, x_] :=
Which[0 <= x <= c, {2, n - 1, x/c*q + p},
c <= x <= c + d, {2, n, (x - c)/d*p},
c + d <= x <= 1, {1, n + 1, (x - (c + d))/(1 - c - d)*(1 - a - b)}]
s2[s_, t_, c_, d_, p_, q_, n_, x_] :=
Which[0 <= x <= 1 - s - t, {2, n - 1,
x/(1 - s - t)*(1 - p - q) + p + q},
1 - s - t <= x <= 1 - s, {3,
n - 1, (x - (1 - s - t))/t*(1 - c - d) + c + d},
1 - s <= x <= 1, {3, n, (x - (1 - s))/s*d + c}]
s3[c_, a_, b_, s_, t_, n_, x_] :=
Which[0 <= x <= 1 - a - b, {4, n - 1, x/(1 - a - b)*t + 1 - s - t},
1 - a - b <= x <= 1 - a, {4, n, (x - (1 - a - b))/b*(1 - s - t)},
1 - a <= x <= 1, {3, n + 1, (x - (1 - a))/a*c}]
s4[p_, q_, s_, a_, b_, n_, x_] :=
Which[0 <= x <= p, {4, n - 1, x/p*s + 1 - s},
p <= x <= p + q, {5, n - 1, (x - p)/q*a/(a + b) + b/(a + b)},
p + q <= x <= 1, {5, n, (x - (p + q))/(1 - p - q)*b/(a + b)}]
F[{k_, n_, x_}] :=
Which[k == 0, s0[a, b, x],
k == 1, s1[a, b, c, d, p, q, n, x],
k == 2, s2[s, t, c, d, p, q, n, x],
k == 3, s3[c, a, b, s, t, n, x],
k == 4, s4[p, q, s, a, b, n, x]]
G[x_] := NestWhile[F, {0, 0, x}, Function[e, Extract[e, {1}] != 5]]
H[x_] := Extract[G[x], {2}] + Extract[G[x], {3}]
H[0]
For the above code to run, one needs to specify the list
{a,b,c,d,p,q,s,t}
And the output are real numbers. How does one define a function in a,b,c,d,p,q,s,t that spits out these real numbers?
Your essential problem is that you have a large number of parameters in your auxiliary functions, but your big-letter functions (F, G and H and by the way single-capital-letter function names in Mathematica are a bad idea) only take three parameters and your auxiliary functions (s0 etc) only return three values in the returned list.
You have two possible ways to fix this.
You can either redefine everything to require all the parameters required in the whole system - I'm assuming that common parameter names across the auxiliary functions really are common values - like this:
G[x_, a_, b_, c_, d_, p_, q_, s_, t_] :=
NestWhile[F, {0, 0, x, a, b, c, d, p, q, s, t},
Function[e, Extract[e, {1}] != 5]]
or
You can set some options that set these parameters globally for the whole system. Look up Options and OptionsPattern. You would do something like this:
First, define default options:
Options[mySystem] = {aa -> 0.2, bb -> 1., cc -> 2., dd -> 4.,
pp -> 0.2, qq -> 0.1, ss -> 10., tt -> 20.}
SetOptions[mySystem, {aa->0.2, bb->1., cc->2., dd->4., pp->0.2,
qq->0.1, ss->10., tt->20.}]
Then write your functions like this:
F[{k_, n_, x_}, OptionsPattern[mySystem]] :=
With[{a = OptionValue[aa], b = OptionValue[bb], c = OptionValue[cc],
d = OptionValue[dd], p = OptionValue[pp], q = OptionValue[qq],
s = OptionValue[ss], t = OptionValue[tt]},
Which[k == 0, s0[a, b, x], k == 1, s1[a, b, c, d, p, q, n, x],
k == 2, s2[s, t, c, d, p, q, n, x], k == 3,
s3[c, a, b, s, t, n, x], k == 4, s4[p, q, s, a, b, n, x]] ]
There is also something quite wrong with your use of Extract (you are assuming there are more parts in your list than are actually there in the first few iterations), but this answers your main issue.
I have a long expression that I would like to split into a collection of terms. For example say I have:
a + b - c + d + 4*e - 3*f
I want to split the expression by addition/subtraction into:
{a, b, -c, d, 4*e, -3*f}
My motivation for this is that I want to deal with the original expression term by term. Is this possible?
Edit: The examples given are VERY simplistic compared to what I'm actually dealing with in Mathematica, it's just that I'm not sure how to write Math around here.
To split the expression, you need to use Level. Level gives you a list of subexpressions and you can specify the level at which you want the subexpressions returned. In this case, you need levelspec 1.
In[1]:= expr = a + b - c + d + 4 e - 3 f;
In[2]:= Level[expr, 1]
Out[2]= {a, b, -c, d, 4 e, -3 f}
An example with a slightly more complicated expression:
In[3]:= expr2 = a^2 + 5 bc/ef - Sqrt[g - h] - Cos[i]/Sin[j + k];
In[4]:= Level[expr2, 1]
Out[4]= {a^2, (5 bc)/ef, -Sqrt[g - h], -Cos[i] Csc[j + k]}
Since no one else has mentioned it, equivalent to Yoda's Level[expr, 1] construction is to use Apply to replace the head of an expression with List:
In[1]:= expr = a + b - c + d + 4 e - 3 f;
In[2]:= List ## expr
Level[expr, 1] == %
Out[2]= {a, b, -c, d, 4 e, -3 f}
Out[3]= True
In[4]:= expr2 = a^2 + 5 bc/ef - Sqrt[g - h] - Cos[i]/Sin[j + k];
In[5]:= List ## expr2
Level[expr2, 1] == %
Out[5]= {a^2, (5 bc)/ef, -Sqrt[g - h], -Cos[i] Csc[j + k]}
Out[6]= True
The two methods do basically the same thing and have identical timings (using my version of a average timing function)
In[1]:= SetOptions[TimeAv, Method -> {"MinNum", 80000}, "BlockSize" -> 20000];
In[7]:= List ## expr // TimeAv
Total wall time is 0.244517, total cpu time is 0.13
and total time spent evaluating the expression is 0.13
The expression was evaluated 80000 times, in blocks of 20000 runs. This yields
a mean timing of 1.625*10^-6 with a blocked standard deviation of 2.16506*10^-7.
Out[7]= {1.625*10^-6, {a, b, -c, d, 4 e, -3 f}}
In[8]:= Level[expr, 1] // TimeAv
Total wall time is 0.336927, total cpu time is 0.16
and total time spent evaluating the expression is 0.16
The expression was evaluated 80000 times, in blocks of 20000 runs. This yields
a mean timing of 2.*10^-6 with a blocked standard deviation of 3.53553*10^-7.
Out[8]= {2.*10^-6, {a, b, -c, d, 4 e, -3 f}}
You might also be able to use MonomialList, if you expression is a polynomial:
In[56]:= MonomialList[a + b - c + d + 4*e - 3*f]
Out[56]= {a, b, -c, d, 4 e, -3 f}
(Doesn't work on non-polynomials, such as Yoda's expr2.)
You could also use Replace:
In[65]:= Replace[a + b - c + d + 4*e - 3*f, HoldPattern[Plus[a___]] :> {a}]
Out[65]= {a, b, -c, d, 4 e, -3 f}
You need to use HoldPattern (or some equivalent trick) to prevent Plus[a__] from evaluating to a__, which has the result of just wrapping the first argument in a list instead of creating a list of the arguments to Plus.
I have here a complicated bit of code that is not pretty nor easy to follow, but it represents a simplification of a larger body of code I am working with. I am a Mathematica novice and have already received some help on this issue from stackoverflow but it is still not solving my problem. Here is the code for which I hope you can follow along and assume what I am trying to get it to do. Thanks to you programming whizzes for the help.
a[b_, c_] = -3*b + 2*c + d + e + f;
g[b_, c_] := If[a[b, c] < 0, -3*a[b, c], a[b, c]];
h[T_, b_, c_] = (T/g[b, c]);
i[h_, T_, b_, c_] := If[h[T, b, c] > 0, 4*h[T, b, c], -5*h[T, b, c]];
j[b_, c_] := If[a[b, c] < 0, 5*a[b, c], 20*a[b, c]];
XYZ[h_, T_, i_, g_, j_, b_, c_] = T*i[h, T, b, c]*g[b, c] + j[b, c]
rules = {a -> 1, b -> 2, c -> 3, d -> 4, e -> 5, f -> 6, T -> 10};
XYZ[h, T, i, g, j, b, c] //. rules
Preserving as much of your code as possible, it will work with just a few changes:
a[b_, c_] := -3*b + 2*c + d + e + f;
g[b_, c_] := If[# < 0, -3 #, #] & # a[b, c]
h[T_, b_, c_] := T / g[b, c]
i[h_, T_, b_, c_] := If[# > 0, 4 #, -5 #] & # h[T, b, c]
j[b_, c_] := If[# < 0, 5 #, 20 #] & # a[b, c]
XYZ[h_, T_, i_, g_, j_, b_, c_] := T*i[h, T, b, c]*g[b, c] + j[b, c]
rules = {a -> 1, b -> 2, c -> 3, d -> 4, e -> 5, f -> 6, T -> 10};
XYZ[h, T, i, g, j, b, c] /. rules
(* Out= 700 *)
If statements are again externalized, as in the last problem.
all definitions are made with SetDelayed (:=), as a matter of good practice.
The presumed error T - 10 in your rules is corrected to T -> 10
Notice that again ReplaceRepeated (//.) is not needed, and is changed to /.
We still have a nonsensical rule a -> 1 but it does not cause a failure.