How to bring out all factors recursively except one particular term?

I want to write a function

keepOnly[expr_, keep_]


Such that

keepOnly[f[f2*g[g2*h[h2*keep, h1], g1], f1], keep]


becomes

f2*h2*g2*f[g[h[keep, h1], g1], f1]


In other words, we take all the factors out except for the term keep.

• Are you sure that g1 in the list of multiplicative factors is not an error? The pattern suggests that it should be g2. – Shredderroy Dec 7 '18 at 21:30
• @Shredderroy Fixed. Thanks! – ablmf Dec 7 '18 at 22:03

exp = f[f2*g[g2*h[h2*keep, h1], g1], f1];

FixedPoint[Replace[#, a_[b_. c_, d___] /; Not[FreeQ[c, keep]] :> b a[c, d], {0, ∞}] &, exp]


f2 g2 h2 f[g[h[keep, h1], g1], f1]

Alternatively,

FixedPoint[Replace[#, a_[b_. c_?(Not@*FreeQ[keep]), d___] :> b a[c, d], {0, ∞}] &, exp]


f2 g2 h2 f[g[h[keep, h1], g1], f1]

• Doesn't ReplaceRepeated with pretty much the same patterns also do it? ReplaceRepeated[f[f2 * g[g2 * h[h2 * keep, h1], g1], f1], a_[b_ * c_?(Not@*FreeQ[keep]), d_] :> b * a[c, d]] – Shredderroy Dec 7 '18 at 21:27
• I was a bit confused at first because the original question had g1 as one of the multiplicative factors, not g2. – Shredderroy Dec 7 '18 at 21:28
• @Shredderroy, yes ReplaceRepeated also works an is simpler. It doesn't work with the pattern I had tried (a_[b_. c_, d___]), so I used Replace FixedPoint combination. – kglr Dec 7 '18 at 21:57