Efficient Search for specific Terms in symbolic Expression

Question

I have a large symbolic expression with six variables a,b,c,d,e,f per term, roughly like this:

expr=a^2 b c d^2 + 1/2 a b (b + I d) e^3 - 1/8 I a (c + 1/2 I (c + I d))^2 (I b + 1/2 (c + I d)) e f

I want to test whether expr contains terms with c and d and e and f. In the example above, there is one term that fulfills the requirement: (-(1/8)-I/16) a b c d e f.

I want a function g[x], which returns a new expression, only containing terms with c*d*e*f.

I can solve it using Expand and symbolic replacements, but this is very slow, and I was hoping for a much faster way. Does anybody have a suggestion for a faster implementation?

Here is the example code - which first creates the expression (such that we can compare our solutions), then defines g[x], runs it and prints the result and time:

(* Same seed for fair comparison *)
SeedRandom[1];

(* Creating one large expression that has to be analysed *)
func = 0;
For[ii = 1, ii <= 100, ii++,
  rndFull = Product[RandomChoice[{a, b, c, d, e, f}], {i, 6}];
  For[jj = 1, jj <= 60, jj++,
   rndVar0 = RandomChoice[{a, b, c, d, e, f}];
   rndVar1 = RandomChoice[{a, b, c, d, e, f}];
   rndVar2 = RandomChoice[{a, b, c, d, e, f}];
   rndFull = rndFull /. {rndVar0 -> 1/2*(I*rndVar1 + rndVar2)};
   ];
  func += Simplify[Exp[(I*\[Pi])/2*RandomInteger[4]]]*rndFull;
  ];

(* g[x] works correctly but is very slow *)
g[expr_] := (Return[Expand[ZERO*expr] /. {ZERO*c*d*e*f -> c*d*e*f} /. {ZERO -> 0}])


CurrTime = AbsoluteTime[];
Print[g[func]]
(* (-(3066695705460323281748465708319/340282366920938463463374607431768211456)-(592396087826201433092643851215 I)/170141183460469231731687303715884105728) a^2 c d e f-(28061855884788386235225/1267650600228229401496703205376-(1188923985339435970275 I)/158456325028528675187087900672) a b c d e f-(23306256125181506635725/2535301200456458802993406410752-(47084620130455206162825 I)/5070602400912917605986812821504) b^2 c d e f *)
Print[AbsoluteTime[] - CurrTime] (* 4.5930638 sec *)

Does anybody have a suggestion for a faster implementation?

Answer 1

Here is another faster solution:

prune[X_][expr_] := Select[expr, MemberQ[#, X, \[Infinity]] &]
h[expr_] := Plus@@Cases[Expand@prune[c]@prune[d]@prune[e]@prune[f]@expr, c d e f X_] 
r1 = g@func; //Timing
r2 = h@func; //Timing
r1 == r2

{12.0938, Null}

{1.39063, Null}

True

We see a speed up of almost a factor 10.

Answer 2

The following is slightly faster:

r1 = With[{dd = D[func, c, d, e, f]},
    Expand[c d e f Block[{c = 0, d = 0, e = 0, f = 0}, dd]]
]; //AbsoluteTiming

r2 = g[func]; //AbsoluteTiming

r1 === r2

{2.8915, Null}

{3.49264, Null}

True