1
$\begingroup$

Recently, I have run into the problem where I need to collect the the sum of any number of gradients. I have defined a function grad[] to represent the gradient, and a typical question is like:

how to collect

 grad[f]-grad[g]+grad[h]-grad[p]

into

grad[f-g+h-p]

Gradient can be collected this way since it is a linear operator. And so do other linear operators. I know I can write a binary rule and use ReplaceRepeated[] like:

grad[f]-grad[g]+grad[h]-grad[p]//.grad[a_]+grad[b_]:>grad[a+b]

But the problem is, I am not satisfied with the algorithm efficiency of ReplaceRepeated[]. What I want is a patterned rule which does the trick with using ReplaceAll[] once rather than repeatedly.

Any idea how to achieve this?

Improve this question
$\endgroup$
2
  • $\begingroup$ Does Distribute[grad[f]-grad[g]+grad[h]-grad[p] /. a_ * grad[x_] :> grad[ a * x ], grad] solve your problem? $\endgroup$ Commented Jun 28, 2022 at 12:50
  • $\begingroup$ Thanks @BenIzd. Your code works if I decide to write an individual method or function called CollectGradient[]. However, what I want is a rule which can be used by ReplaceAll[] once, your code seems not quite applicable in this case for the reasons: 1. The pattern of expression needs recognizing before the expression can be manipulated. 2. If your code is used as the r.h.s of the rule, there might appear nested replacement rules, I am not sure if that works. $\endgroup$ Commented Jun 28, 2022 at 13:40

2 Answers 2

Reset to default
2
$\begingroup$

linearCombine from Pushing Mathematica's FullSimplify to a global complexity minimum does the job:

ClearAll[linearCombine]; Module[{f}, SetAttributes[f, NumericFunction]; constantQ = NumericQ[# /. s_Symbol /; MemberQ[Attributes[s], Constant] :> f[0]] &]; linearCombine[e_Plus, head_, constants_List : {}] := Block[constants, SetAttributes[#, Constant] & /@ constants; head@Replace[e, {c_?constantQ*head[a_] :> c*a, head[a_] :> a}, 1] /; MatchQ[e, _[((_?constantQ)*_head | _head) ..]]]; linearCombine[grad[f] - grad[g] + grad[h] - grad[p], grad] (* grad[f - g + h - p] *)
Improve this answer
$\endgroup$
3
  • $\begingroup$ Thanks Michael. I am really impressed by your ingenious method. However, like I said to Ben in the comment under my original post, your code is very nice if I want to write an individual method or function doing this, but what I want is a patterned rule which can be used by ReplaceAll[] once, and your code might be too complicated for that purpose. $\endgroup$ Commented Jun 29, 2022 at 9:49
  • $\begingroup$ @AlbertLew lcRule = DownValues@linearCombine is such a rule. constantQ may be replaced by NumericQ if you don't want it to deal with symbolic constants. $\endgroup$ Commented Jun 29, 2022 at 13:26
  • $\begingroup$ Thanks Michael, I have tested the rule generated by DownValues and found that the expr has to be enclosed in linearCombine[ ,grad] then ReplaceAll[] to make it work. Without the wrapper linearCombine[ ,grad] and letting ReplaceAll[] directly handle the expr like grad[f] - grad[g] + grad[h] with the rules won't work, which certainly leaves the way you suggested somewhat inconvenient since there are a lot of other rules which can directly be applied to the expr by /.. This specific rule regarding collecting grad [] should be able to work together with them in a big rule List. $\endgroup$ Commented Jun 30, 2022 at 4:21
1
$\begingroup$

You might try TagSet, something like this:

grad /: Times[-1, grad[x_]] := grad[-x] grad /: Plus[ps___, grad[x_], qs___, grad[y_], rs___] := Plus[grad[x + y], ps, qs, rs]

The definition of Times might need to be extended depending on what sorts of expressions you expect to encounter. Also, some care might need to be taken to avoid nesting of grad. The definition for Plus might be overkill--I didn't do any real testing.

Improve this answer
$\endgroup$
2
  • $\begingroup$ Thanks lericr. The TagSet method is an efficient and thorough way to define the form a particular pattern renders, and I do find it helpful to addressing my problem in terms of the form in which the operator applied to the product of a number and a symbol renders. For example, grad /: grad[Times[n_?NumberQ,x_]] := n grad[x]. But for the dealing of Plus, I do not think it is a good idea, since both the expanded form like grad[f]+grad[g]-grad[h] and collected form like grad[f+g-h] are needed, while once tag set is made, only one form can exist, with the other gone completely. $\endgroup$ Commented Jun 29, 2022 at 6:14
  • $\begingroup$ Well, I don't know anything about your actual domain, so have a grain of salt at the ready... When you say that both forms are needed, that suggests different semantics. I like to indicate different semantics with different symbols. So, you could use the TagSet suggestion for one symbol, for illustration let's say grad1 and your regular grad for the non-collected form. Then you can do your ReplaceAll but in a simpler way: grad -> grad1 $\endgroup$ Commented Jun 29, 2022 at 18:22

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.