6
$\begingroup$

Suppose I have an expression which is a collection of symbols and integers arbitrarily combined with Plus and Times. For example,

A = a + c (d - a b d) + e c (a + b) f + b - 1

B = a + b a c d

(where a, b, c, d, e, f are all different symbols), although it could be longer and more complicated.

I want to estimate the expression by reducing it to only the terms with zero or one symbol multiplied together because the symbols all represent small numbers, and I want a first-order approximation:

Ar = a + b - 1

Br = a

How can I automate this in Mathematica? Assume that any constants are stand-alone and don't have to be distributed.

Improve this question
$\endgroup$
5
  • $\begingroup$ Please clarify whether that "symbolic expression" is a polynomial in many variables. $\endgroup$ Commented yesterday
  • $\begingroup$ @user64494 yes, it is a polynomial in many variables, added and multiplied together in arbitrary combination. I want to exclude any term which has at least two variables multiplied. $\endgroup$ Commented yesterday
  • $\begingroup$ People here generally like users to post code as copyable Mathematica code as well as images or TeX, so they can copy-paste it. It makes it convenient for them and more likely you will get someone to help you. You may find the meta Q&A, How to copy code from Mathematica so it looks good on this site, helpful $\endgroup$ Commented yesterday
  • $\begingroup$ @MichaelE2 thank you for the suggestion. $\endgroup$ Commented yesterday
  • $\begingroup$ Thanks for the edit. :) $\endgroup$ Commented yesterday

9 Answers 9

Reset to default
6
$\begingroup$

Update: Sorry, my internet was sporadically on, mostly out, after I first posted.

V14.3 solution

Eventually, I hope to find the Q&A where this issue arose with a change in behavior of Series[] that @azerbajdzan alludes to, whether knowingly or not. After the comment, I recalled someone coming up with the following workaround. I may have been me, ironically. I include it in case someone coming across this Q&A is looking for a way to cull the up-to-linear terms of an expression that has only high-order terms.

Normal[(A /. v : Alternatives @@ Variables[A] :> v $t) + 
   O[$t]^2] /. $t -> 1

(*  -1 + a + b  *)

Normal[(a^4 /. v : Alternatives @@ Variables[A] :> v $t) + 
   O[$t]^2] /. $t -> 1

(*  0  *)

Here is one reference to the issue in V14.3 by @Acacia, with the above solution by me, tee-hee:

Early-version alternate solution

Here is the standard way (I think it's found in several places on site):

Normal@Series[
   A /. v : Alternatives @@ Variables[A] :> v $t, {$t, 0, 
    1}] /. $t -> 1

(*  -1 + a + b  *)

Explanation

First, Variables[A] finds all variables in the expression:

Variables[A]
(* {a, b, c, d, e, f} *)

The code

v : Alternatives @@ Variables[A] :> v $t
(* v : a | b | c | d | e | f :> v $t *)

creates a replacement rule that can be understood as follows. First, v : ... gives an explicit name v to the stuff that follows. The expression a | b | c | d | e | f read roughly as a or b or c or d or e or f (although this isn't the logical operator Or; instead, this is what's used in pattern matching to indicate that any of those expressions match the pattern)

Thus, v : a | b | c | d | e | f reads as "If the expression is exactly the same as a or b or c or d or e or f, call that expression v". Then, the replacement rule means to take such a v and replace it with v*$t, where $t is just a place-holder variable name.

Finally, we apply the replacement rule using ReplaceAll (/.), and so

A /. v : Alternatives @@ Variables[A] :> v $t

replaces every instance of a or b or c or d or e or f that appears in A with the same variable but multiplied by $t.

Finally, we perform a Taylor series about $t=0 out to first order, which will keep only terms that have one instance of the variables. Finally, Normal cuts off the O[$t]^2 term so that we can turn this back into a standard expression, and we replace every instance of $t with 1 using ... /. $t ->1 to get back the original variables.

Improve this answer
$\endgroup$
12
  • $\begingroup$ Thank you! I suppose my next question on this site should be an explanation of how this works. lol $\endgroup$ Commented yesterday
  • $\begingroup$ Is it a bug in Series or bug in your code, because for A=a^4 it does not seem to produce a correct output. Looks more like a bug in Series though. $\endgroup$ Commented yesterday
  • $\begingroup$ @azerbajdzan it's a good question, but I only included Plus and Times within the scope of the question, not Power. $\endgroup$ Commented yesterday
  • $\begingroup$ @Gilbert a^4 == Times[a,a,a,a] $\endgroup$ Commented yesterday
  • $\begingroup$ @azerbajdzan - Add and subtract a constant, e.g., (Normal@Series[(A + 1) /. v : Alternatives @@ Variables[A] :> v $t, {$t, 0, 1}] /. $t -> 1) - 1 $\endgroup$ Commented yesterday
4
$\begingroup$

A variation of Michael E2's answer that uses O instead of Series and thus avoids its bug.

A = a + c (d - a b d) + e c (a + b) f + b - 1;

Normal[(A /. v : Alternatives @@ Variables[A] :> v $t) + 
   O[$t]^2] /. $t -> 1

-1 + a + b
Improve this answer
$\endgroup$
4
$\begingroup$

Personally, I find that CoefficientRules/FromCoefficientRules is by far the most robust way to manipulate multivariate polynomials without having to worry about arcane and ad-hoc parsing tricks. For the problem of finding terms of order $\leq1$, we can simply use a Select to filter the total exponent of the monomials:

Arules = CoefficientRules[A]
(* {{1, 1, 1, 1, 0, 0} -> -1, {1, 0, 1, 0, 1, 1} -> 
     1, {1, 0, 0, 0, 0, 0} -> 1, {0, 1, 1, 0, 1, 1} -> 
     1, {0, 1, 0, 0, 0, 0} -> 1, {0, 0, 1, 1, 0, 0} -> 
     1, {0, 0, 0, 0, 0, 0} -> -1} *)
FromCoefficientRules[Select[Arules, Total[Keys[#]] <= 1 &], Variables[A]]
(* -1 + a + b *)
Improve this answer
$\endgroup$
3
$\begingroup$

A long, but understandable, way is as follows. First,

A = Expand[2 a + c (d - a b d) + e c (a + b) f + b - 1];
var = Variables[A];

Second, we form the list of the terms of A by

mono = MonomialList[A, var]

{-a b c d, a c e f, 2 a, b c e f, b, c d, -1}

Third, we create the list of the lists of degrees of each term with respect to each variable through

Map[Exponent[#, var] &, mono]

{{1, 1, 1, 1, 0, 0}, {1, 0, 1, 0, 1, 1}, {1, 0, 0, 0, 0, 0}, {0, 1, 1, 0, 1, 1}, {0, 1, 0, 0, 0, 0}, {0, 0, 1, 1, 0, 0}, {0, 0, 0, 0, 0, 0}}

and then we find the total degree of each term by

Map[Total[#] &, Map[Exponent[#, var] &, mono]]

{4, 4, 1, 4, 1, 2, 0}

Fourth, we choose the terms of the total degree less than or equal to one and add those terms

Select[mono, Total[#] &@Exponent[#, var] <= 1 &] // Total

-1 + 2 a + b

Edit. 2a instead of a in A and style.

Improve this answer
$\endgroup$
1
  • 1
    $\begingroup$ Ah, a non-Series solution! Thank you. $\endgroup$ Commented yesterday
2
$\begingroup$

Another way using CoefficientList:

LinearData[expr_] := 
  Module[{vars, tensor, positions, linear, constant, data},
   vars = Variables[expr];
   tensor = CoefficientList[Expand[expr], vars];
   positions = 
    ReplacePart[ConstantArray[1, Length[vars]], # -> 2] & /@ 
     Range[Length[vars]];
   linear = AssociationThread[vars -> Extract[tensor, positions]];
   constant = tensor[[Sequence @@ ConstantArray[1, Length[vars]]]];
   data = <|"Constant" -> constant, "Linear" -> linear|>;
   Total@KeyValueMap[#1 #2 &, data["Linear"]] + data["Constant"]
   ];

LinearData /@ {3 a + c (d - a b d) + e c (a + b) f + 2 b - 1, 
              a + b a c d, b a c d + b c, a^4 + b a c d + b^8}

{-1 + 3 a + 2 b, a, 0, 0}

Improve this answer
$\endgroup$
1
$\begingroup$

Perhaps a short alternative version (No "Series bug" detected)

Normal[Series[
A /. Thread[Variables[A] -> eps Variables[A]], {eps, 0, 1}]] 
/.eps -> 1 (* -1 + a + b*)

Normal[Series[
B /. Thread[Variables[B] -> eps Variables[B]], {eps, 0, 1}]] /. 
eps -> 1 (* a *)
Improve this answer
$\endgroup$
2
  • $\begingroup$ You probably use some older version if no bug detected, because on 14.3.0 it suffers from the same bug as in Michael E2 answer. $\endgroup$ Commented yesterday
  • $\begingroup$ @azerbajdzan You're right, my version is 12.2 $\endgroup$ Commented yesterday
1
$\begingroup$

CoefficientArrays[] is another algebraic operator that may be used for this algebraic operation, since it gives a list of {constant, linear, quadratic,...} coefficients:

Replace[
 CoefficientArrays[A, Variables[A]],
 {{const_} :> const,
  {const_, linear_, ___} :> const + linear . Variables[A]}]

(*  -1 + a + b  *)

Variation: getting the coefficients of a dummy variable, replacing each variable $v \mapsto vt$ (as in my other Series[] answer):

Total[CoefficientArrays[
   A /. v : Alternatives @@ Variables[A] :> v $t, $t][[;; UpTo[2]]],
 All]
(*  -1 + a + b  *)
Improve this answer
$\endgroup$
0
$\begingroup$

Instead of introducing a formal expansion parameter via Series, the first–order truncation can be obtained directly at the structural level. The idea is simple: expand the expression into a sum of monomials, and then discard every term that contains nonlinear symbolic interactions:

FirstOrderApproximation[expr_] := ReplaceAll[Expand @ expr,
    {
            Times[s1_Symbol, s2_Symbol, rest___] :> 0,
            Power[s_Symbol, n_ /; Greater[n, 1]] :> 0
        }
   ];

Map[FirstOrderApproximation,
{3 a + c (d - a b d) + e c (a + b) f + 2 b - 1,
a + b a c d,
b a c d + b c,
a^4 + b a c d + b^8}]

(*{-1 + 3 a + 2 b, a, 0, 0}*)

Why this works?

  • Expand brings the expression to a canonical polynomial form, a flat sum of products.

  • After expansion, each term is an explicit Times expression. Since Times is Orderless, any product involving two or more symbolic factors matches s1_Symbol * s2_Symbol * rest___ and is removed, regardless of ordering or numeric coefficients.

  • Powers such as a^2 are eliminated by the second rule.

The result is precisely the collection of constant and linear terms, i.e. the first–order approximation in the symbolic variables.

Alternatively, the same idea can be expressed by explicitly counting symbolic factors in each term, removing any product that contains two or more symbols:

Expand[expr] /. {
  t_Times /; Count[t, _Symbol, ∞] >= 2 :> 0,
  s_Symbol^n_ /; n > 1 :> 0
}
Improve this answer
$\endgroup$
0
$\begingroup$

Another among endless variations:

Expand[A] //
 Replace[
   #,
   Except[c_ | c_. _Symbol /; NumericQ[c]] -> 0,
   {Boole[Head[#] === Plus]}] &

(*  -1 + a + b  *)
Improve this answer
$\endgroup$

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.