How to define the following "derivative"?

Consider the following test expression:

exprtest =
f[x, a1]^2*f[x, a2]^2 + f[x, a1] d[x, a1] + f[x, a2] c[x, a2] +
df[x, a1, a2]*dc[x, a1, a2] + df[x, b3, c4] dc[x, b3, c4] +
df[x, b5, c9] dd[x, b5, c9];


It is made of "fields" f,c,d and their "derivatives" df,dc,dd (and may also include some constants tensor[a,b,c,d]). The "field" depends on a some parameter x and an "index" a, while the "derivative" depends on two indices a,b. In exprtest, different labels for the indices are used.

Let us define the symbols for "fields" and "derivatives":

{Fsymbol["f", x, a_] = f[x, a], Fsymbol["c", x, a_] = c[x, a],
Fsymbol["d", x, a_] = d[x, a]};
{dFsymbol["f", x, a_, b_] = df[x, a, b],
dFsymbol["c", x, a_, b_] = dc[x, a, b],
dFsymbol["d", x, a_, b_] = dd[x, a, b]};


Let us also define the list of labels of the indices that are used in exprtest:

indiceslist = {a1, a2, b3, c4, b5, c9};


I would like to compute the derivative Der[field,index] of exprtest with respect to the "field" and "derivative" which, in addition to the standard differentiation rules (like $$dx^{4}/dx = 4x^{3}$$), replaces field[x,a_]*expr[a_,...] with expr[index] and fieldderivative[x,a_,b_]*expr[a_,b_,...] with i*p[fieldlabel,a]expr[a,index,...].

This is how I implement it:

Der[field_, index_] :=
Sum[D[exprtest, Fsymbol[field, x, indiceslist[[i]]]] +
Sum[I*p[field, indiceslist[[j]]]*
D[exprtest,
dFsymbol[field, x, indiceslist[[j]], indiceslist[[i]]]], {j, 1,
Length[indiceslist], 1}] /. {indiceslist[[i]] -> index}, {i, 1,
Length[indiceslist], 1}]
Der["f", \[Kappa]]


I p(f,a1) dc(x,a1,[Kappa])+2 f(x,a1)^2 f(x,[Kappa])+2 f(x,a2)^2 f(x,[Kappa])+I p(f,b3) dc(x,b3,[Kappa])+I p(f,b5) dd(x,b5,[Kappa])+c(x,[Kappa])+d(x,[Kappa])

It first sums the differentiation by the fields (and derivatives) with indices labels occurring in the Lagrangian, and then replaces the labels with the desired final label.

But it is ugly and slow, introducing two summations over the possible labels. In addition, the list of labels may be very broad and changing, so it may be complicated to define it from the very beginning (and hence use my realization).

Could you please tell me if there is an analog of my Der function that does not care about different labels for the indices and, in particular, does not involve the summation of the labels occurring in exprtest?

• First, I don't think you need to define all those Fsymbol and dFsymbol. Instead of Fsymbol[field, x, i], you can just write field[x, i]. And instead of dFsymbol[field, x, i, j], you write Symbol["d" <> ToString[field]][x, i, j]. Second, no need to manually define indiceslist, just retrieve them from the expression: indiceslist = DeleteDuplicates[Flatten[Rest@*List @@@ Variables[exprtest]]]. Aug 13, 2023 at 12:30
• Der[field_, index_] := Sum[D[exprtest, field[x, indiceslist[[i]]]] + Sum[I*p[field, indiceslist[[j]]]*D[exprtest, Symbol["d" <> ToString[field]][x, indiceslist[[j]], indiceslist[[i]]]], {j, 1, Length[indiceslist], 1}] /. {indiceslist[[i]] -> index}, {i, 1, Length[indiceslist], 1}] Aug 13, 2023 at 12:30
• @Domen : Thanks! Please also take a look at my version of the solution (the answer below). Aug 13, 2023 at 12:31
• @Domen : the problem with the summation inside Der is that it is potentially slow in the cases when I have a lot of summands in the polynomial. Aug 13, 2023 at 12:34
• Is it just potentially slow or is it actually slow? Aug 13, 2023 at 12:40

I still think there is nothing particularly wrong with your code apart from it being written a bit clumsily.

Let me summarize the main improvements:

1. Use Sum[...i..., {i, indiceslist}] instead of Sum[...indiceslist[[i]]..., {i, 1, Length[indiceslist], 1}].
2. No need to define all those Fsymbol and dFsymbol. Although it would be more convenient if you used some other construction for derivatives (for example d[f, x, a, b] or d[f][x, a, b] instead of concatenating symbol names df[x, a, b]), you can still programmaticaly construct the derivative with Symbol["d" <> ToString[field]][x, j, i].
3. No need to manually construct indiceslist when you can extract all indices directly from the expression.
4. Do not expand the powers before differentiating; do it afterwards.

The code is then:

Der[expr_, x_, field_, index_] := Module[{indices},
indices = Complement[DeleteDuplicates[Cases[Variables[exprtest],
_[lst__] :> lst]], {x}];

Sum[D[expr, field[x, i]] +
Sum[I*p[field, j]*
D[expr, Symbol["d" <> ToString[field]][x, j, i]] /. {i -> index},
{j, indices}], {i, indices}]
]

Der[exprtest, x, f, κ]
(* c[x, a2] + d[x, a1] + 2 f[x, a1]^2 f[x, a2] + 2 f[x, a1] f[x, a2]^2 +
I dc[x, a1, κ] p[f, a1] + I dc[x, b3, κ] p[f, b3] +
I dd[x, b5, κ] p[f, b5] *)


The code is still very fast for powers if you just don't expand them prior to differentiation.

(res1 = Der[exprtest^30, f, κ]) // AbsoluteTiming // First
(* 0.003008 *)
(res2 = Der[exprtest^30 // Expand, f, κ]) // AbsoluteTiming // First
(* 12.8399 *)

Simplify[res1 - res2]
(* 0 *)


I came up with a version of the solution. It uses this answer.

So first, I define the rules for derivatives of "fields" and their "derivatives" with respect to the corresponding "fields":

f /: D[f[x_, a_], f[x_, b_], OptionsPattern[]] :=
If[MemberQ[OptionValue[NonConstants], f], KroneckerDelta[a, b], 0]
df /: D[df[x_, a_, b_], f[x_, c_], OptionsPattern[]] :=
If[MemberQ[OptionValue[NonConstants], df],
I*p["f", a] KroneckerDelta[b, c], 0]
c /: D[c[x_, a_], c[x_, b_], OptionsPattern[]] :=
If[MemberQ[OptionValue[NonConstants], c], KroneckerDelta[a, b], 0]
dc /: D[dc[x_, a_, b_], c[x_, c_], OptionsPattern[]] :=
If[MemberQ[OptionValue[NonConstants], dc],
I*p["c", a] KroneckerDelta[b, c], 0]
d /: D[d[x_, a_], d[x_, b_], OptionsPattern[]] :=
If[MemberQ[OptionValue[NonConstants], d], KroneckerDelta[a, b], 0]
dd /: D[dd[x_, a_, b_], d[x_, c_], OptionsPattern[]] :=
If[MemberQ[OptionValue[NonConstants], dd],
I*p["d", a] KroneckerDelta[b, c], 0]


Then, I compute the derivative:

Der1[field_, index_] := Block[{},
expr10 =
D[exprtest, Fsymbol[field, x, index],
NonConstants -> {Fsymbol[field, x, a][[0]],
dFsymbol[field, x, a, b][[0]]}];
expr10 //. e_*KroneckerDelta[x_, y_] :> (e /. x -> y)
]
If[Der1["f", \[Kappa]] == Der["f", \[Kappa]], "True"]


The problem with this solution is that I would need to define a huge number of rules manually, for all the "fields" and the "derivatives" that are present in the expression. For three "fields" and "derivatives", I already need to type 6 long strings of code manually. But in the real case, I have 20-30 "fields".

If powering exprtest by 30 and removing the last string in the definition of Der1 (with Kroneckers replacement), it is ~3 times faster than Der. With this line being included, however, Der1 is even somewhat slower than Der. So neither Der nor Der1 are optimal: Der suffers from the summation of the derivative of the same huge expression over indices, while Der1 - from the symbolic replacements (the derivative itself is much faster).

• If you need to manually write the same thing three times, you should probably automatize it. Aug 13, 2023 at 12:35