1
$\begingroup$

I have an expression consisting of a sum of terms. It looks like this in simplified form:

$-\frac{e^{-t/t_1} \,a \, b \, c}{d} \, U_1 - \frac{e^{-t/t_2} \,a \, e \, c}{d} \, U_2 -\frac{e^{-t/t_2} \,a \, f \, c}{d} \, U_2 - \frac{e^{-t/t_3} \,a \, g \, c}{d} \, U_3 - \frac{e^{-t/t_3} \,a \, b \, c}{h} \, U_3 - \frac{e^{-t/t_3} \,a \, f \, g \, {\bf{Eidx}}}{h} \, U_3 - \frac{e^{-t/t_3} \,a \, b \, e \, {\bf{Esx}}}{h} \, U_3 - \frac{e^{-t/t_3} \,a \, b \, g \, {\bf{Eidx}}}{h} \, U_3 \, - \frac{e^{-t/t_7} \,a \, c^2}{k} \, U_7 - \frac{e^{-t/t_{10}} \,b \, l \, {\bf{Esx}}}{k} \, U_{10} \, - \, ...$

Here is the Wolfram code for the whole expression:

expr = -(((E^(-(t/Subscript[t, 1]))) a b c )/d) Subscript[U, 1] - (
    E^(-(t/Subscript[t, 2])) a e c)/d Subscript[U, 2] - (
    E^(-(t/Subscript[t, 2])) a f c)/d Subscript[U, 2] - (
    E^(-(t/Subscript[t, 3])) a g c)/d Subscript[U, 3] - (
    E^(-(t/Subscript[t, 3])) a b c)/h Subscript[U, 3] - (
    E^(-(t/Subscript[t, 3])) a f g Eidx)/h Subscript[U, 3] - (
    E^(-(t/Subscript[t, 3])) a b e Esx)/h Subscript[U, 3] - (
    E^(-(t/Subscript[t, 3])) a b g Eidx)/h Subscript[U, 3] - (
    E^(-(t/Subscript[t, 7])) a c^2)/k Subscript[U, 7] - (
    E^(-(t/Subscript[t, 10])) b l Esx)/k Subscript[U, 10] - (
    E^(-(t/Subscript[t, 11])) a e Eidx)/k Subscript[U, 11] - (
    E^(-(t/Subscript[t, 12])) a d^2 Esx)/k Subscript[U, 12] + (
    E^(-(t/Subscript[t, 12])) a c e Esx)/k Subscript[U, 12] - (
    E^(-(t/Subscript[t, 12])) a b d Esx)/k Subscript[U, 12];

I would like first to identify terms in my expression that contain certain multiplication factors, then record the prefactors in these terms in individual lists for each factor. The factors that I am interested in are Eidx and Eidx, which I have indicated in bold above.

I have managed to generate lists for Esx and Eidx successfully. However, I also wish to generate a third list containing all coefficients of $U$, where neither Esx, nor Eidx appears. Hence I want a list that looks like this:

$\{-\frac{e^{-t/t_1} \,a \, b \, c}{d}, - \frac{e^{-t/t_2} \,a \, e \, c}{d} - \frac{e^{-t/t_2} \,a \, f \, c}{d}, - \frac{e^{-t/t_3} \,a \, g \, c}{d} - \frac{e^{-t/t_3} \,a \, b \, c}{h},0,0,0, - \frac{e^{-t/t_7} \,a \, c^2}{k},0,0,0,...\}$,

where the position in the list corresponds to the subscript of $U$.

I've coded the generation of this third list in this way:

CoeffU = Table[If[Length[Coefficient[expr,Subscript[U, i]]] != 0,
 Select[Coefficient[expr,Subscript[U, i]],FreeQ[#,Esx|Eidx] &],0],
 {i,1,15}]

This does work for the majority of the terms but fails when there is only one term for a given subscript of $U$ that is multiplied by either Esx or Eidx (e.g., the one for $U_{10}$). In those cases, Mathematica evidently assumes that the terms are multiplicative, rather than additive, and returns the same lone term with the Esx or Eidx factor removed $-$ e.g., for $U_{10}$ it returns $- \frac{e^{-t/t_{10}} \,b \, l}{k}$, which is wrong as it should discard the whole term and return 0.

Why does the FreeQ function switch what it considers a term when there is only one term present, and how do I correct for this unexpected behaviour?

$\endgroup$
6
  • 1
    $\begingroup$ Can you provide all expressions in correct Mathematica syntax so that we can copy and paste your code into our own copies? We don't want to have to type all of that out. $\endgroup$
    – march
    Commented May 18 at 21:07
  • $\begingroup$ Of course! I have just added the code for the full (simplified) expression in the main body of the question. $\endgroup$ Commented May 18 at 23:58
  • 1
    $\begingroup$ It's Select that behaves differently, not FreeQ. It selects the expressions from level 1. For a x + b y, level 1 consists of a x and b y. If the expression is simply a x, level 1 consists of a and x. The FullForm of an expression can help see what the levels are. Also Level will tell you what a level consists of. $\endgroup$
    – Michael E2
    Commented May 19 at 0:17
  • $\begingroup$ Thanks, Michael. Level definitely reveals more about what is going on, although I believe the behaviour is associated with Coefficient, rather than Select, viz.: Level[Coefficient[expr, Subscript[U, 10]], 1] produces $\{ -1,b,e^{-\frac{t}{t_{10}}},Esx,\frac{1}{k},l\}$, whereas Level[Coefficient[expr, Subscript[U, 12]], 1] outputs $\{ -\frac{e^{-t/t_{12}} \,a \, b \, d \, Esx}{k}, - \frac{e^{-t/t_{12}} \,a \, d^2 \, Esx}{k}, -\frac{e^{-t/t_{12}} \,a \, c \, e \, Esx}{k}\}$. I.e., the level is incorrect for the singular $U_{10}$ term but correct for the multiple $U_{12}$ terms. $\endgroup$ Commented May 19 at 14:13
  • $\begingroup$ That's exactly what I described. Coefficient[expr, Subscript[U, 10]] has the same form as a x, namely Times[...], and level 1 consists of the six factors of the coefficient. And Coefficient[expr, Subscript[U, 12]] has the same form as a x + b y, namely, Plus[...], and level 1 consists of the three terms of the coefficient, each of which terms are of the form Times[...]. In the first case, Select selects the factors of the coefficient; in the second case, Select selects the terms of the coefficient. Select does not change the head (Times and Plus resp.). $\endgroup$
    – Michael E2
    Commented May 19 at 18:32

2 Answers 2

0
$\begingroup$

The problem you have is that Select analyses the first level of each coefficient list. If the term consists of only one term Select looks at the parts of this term.

A fix is to wrap all coefficients into a list like to make sure that Select does not go into a coefficient:

Table[If[Length[Coefficient[expr, Subscript[U, i]]] != 0, 
  Select[List /@ Coefficient[expr, Subscript[U, i]], 
   FreeQ[#, Esx | Eidx] &], 0], {i, 1, 15}]

enter image description here

If you want to get rid of the additional lists:

Table[If[Length[Coefficient[expr, Subscript[U, i]]] != 0, 
   Select[List /@ Coefficient[expr, Subscript[U, i]], 
    FreeQ[#, Esx | Eidx] &], 0], {i, 1, 15}]  /. {{x_} :> x}

enter image description here

Fix

A simpler and hopefully< correct solution is to first get the coefficients and then set Esx and Eidx to zero:

Table[If[Length[Coefficient[expr, Subscript[U, i]]] != 0, 
  Coefficient[expr, Subscript[U, i]] /. {Esx -> 0, Eidx -> 0}, 0], {i,1, 15}]

enter image description here

$\endgroup$
3
  • $\begingroup$ Thank you, Daniel, but this solution is still not correct – you will see that the third element in your list is missing, when it should be $- \frac{e^{-t/t_3} \,a \, g \, c}{d} - \frac{e^{-t/t_3} \,a \, b \, c}{h}$. $\endgroup$ Commented May 19 at 13:22
  • $\begingroup$ Look at my fix. $\endgroup$ Commented May 21 at 8:37
  • $\begingroup$ Hi Daniel. I spent the last couple of days trying to find a way to control the level of abstraction of the Select function to 'zoom out' one level (which, to my mind, would have been the most robust way of solving the problem) but couldn't come up with anything that worked. I'm developing this code for commercial purposes and it's imperative that the solution works under all circumstances, and that there aren't any 'dropped cases'. However, in light of the fact that there is evidently no other way, your workaround is by far the most concise and logical. Thank you very much for your help! $\endgroup$ Commented May 23 at 23:10
1
$\begingroup$

I think these produce the desired output:

Table[
 If[Length[Coefficient[expr, Subscript[U, i]]] != 0,
  Select[
   Unique[][Esx] + Coefficient[expr, Subscript[U, i]],
   FreeQ[#, Esx | Eidx] &],
  0],
 {i, 1, 15}]

Alternatively, a less hacky way is to test the head of the coefficient:

Table[
 Plus @@ Select[
  Replace[
   Coefficient[expr, Subscript[U, i]],
   {HoldPattern[Plus[a__]] :> List[a],
    c_ :> {c}}],
  FreeQ[#, Esx | Eidx] &],
 {i, 1, 15}]

There may be other problems with an expression-structure approach to making algebraic operations. For instance, should a coefficient ever be of the form -2(x + Esx), should the result be 0 or -2x? The example in the OP suggests that the expression is already in a canonical form, so that this ambiguity does not arise. We leave this comment simply as a warning to other users who might try to adapt the methods here. (Expand[] might help, or possibly Collect[]; but it depends on the use-case.)


An extended explanation and illustration of my comments

As I mentioned in my original comment and subsequent ones, Select[f[a1, a2, a3,...], test] returns f[b1, b2,...] where each bj is an ai for which test[ai] returns True.

A familiar problem is selecting "terms" of expression that is a product or sum of products. For instance, a1 a2 or a1 a2 + b1 b2, or a1 a2 + b1 b2 + c1 c2, and so forth. And of course, terms may have an arbitrary number of factors, such as a1 a2 a3 etc. The relation of the concept "term" to the expression structure is different when the expression is a single term and when it has multiple terms. The easiest approach is to treat both cases separately, which can be done by testing whether the head is Plus, such as in the second method above.

One can use FullForm[], Level[], Trace[], and TracePrint[] to examine how Select[] and FreeQ[[] the OP's code are evaluated. I'd recommend breaking down the code, and examining bits of it; otherwise, the output may be overwhelming.

The following codes shows the FullForm of each call by Select[] to FreeQ[], and indicates the result. Each step is labeled by the trace level and the number of times FreeQ[] has been called. It also shows the expression constructed by Select[] at the end, before the expression has been evaluated (for instance, Plus[], which evaluates to the result 0). The two examples are from the coefficients the OP mentioned in a comment:

foo = 0;
With[{c = Coefficient[expr, Subscript[U, 10]]},
 TracePrint[
  Select[c, FreeQ[Esx | Eidx]],
  HoldPattern[FreeQ[_][_]] | FreeQ | _Times | _Plus,
  TraceAction -> (Print[
      If[MatchQ[#1, HoldForm[FreeQ[_][_]]], ++foo];
      Indent[4 (TraceLevel[] - 2)],
      Row[{"<", TraceLevel[], "-", foo, "> "}, BaseStyle -> Bold],
      FullForm /@ #1] &),
  TraceDepth -> 3
  ]
 ]

enter image description here

foo = 0;
With[{c = Coefficient[expr, Subscript[U, 12]]},
 TracePrint[
  Select[c, FreeQ[Esx | Eidx]],
  HoldPattern[FreeQ[_][_]] | FreeQ | _Times | _Plus,
  TraceAction -> (Print[
      If[MatchQ[#1, HoldForm[FreeQ[_][_]]], ++foo];
      Indent[4 (TraceLevel[] - 1)],
      Row[{"<", TraceLevel[], "-", foo, "> "}, BaseStyle -> Bold],
      FullForm /@ #1] &),
  TraceDepth -> 3
  ]
 ]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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