Map a function at one "part" of each term in a multivariate polynomial

Question

I have polynomials in several variables x[i] and y[j], and I am using First@SymmetricReduce@ twice (first with respect to the x's, then the y's), so that each term of the final result takes the form

symmetric poly in the x[i] * symmetric poly in the y[j].

Now I need to convert the "x" part and "y" part into Schur polynomials separately. I've written the function to do that manually one term at a time, but now how can I map that function at the "x" part of every term simultaneously? (Likewise for the "y" part then.)

Edit: Specifically, given a polynomial in which each term consists of an unspecified number of x[i] factors followed by an unspecified number of y[j] factors, how can I map one function to the "x" part of every term, and then map another function to the "y" part of every term?

The functions I'll be mapping are the following:

    XtoSchur[expr_] := toSchur@(Expand[expr] /. x -> $x);  
    YtoSchur[expr_] := toSchur@(Expand[expr] /. y -> $x);

(The toSchur function is from Coquereaux's SymPol$Package.) But a typical input I begin with looks like this (there are only 6 main terms here):

1 + (x[1]^2 x[2] + x[1] x[2]^2 + x[1]^2 x[3] + x[1] x[2] x[3] + 
       x[2]^2 x[3] + x[1] x[3]^2 + x[2] x[3]^2) y[1] y[2] y[3] + 
x[1]^2 x[2]^2 x[3]^2 y[1]^2 y[2]^2 y[3]^2 + 
(-x[1]^2 x[2] x[3] - x[1] x[2]^2 x[3] - x[1] x[2] x[3]^2) y[1] y[2] y[
   3] (y[1] + y[2] + y[3]) + 
(-x[1] x[2] - x[1] x[3] - x[2] x[3]) (y[1] y[2] + y[1] y[3] + y[2] y[3]) + 
x[1] x[2] x[3] (y[1] + y[2] + y[3]) (y[1] y[2] + y[1] y[3] + y[2] y[3])

So every term has an "x" part followed by a "y" part, but I can't figure out how to make a function map at each of the "x" parts at once (and then another function map at all the "y" parts).

An example of some input and the problematic output of your code would be helpful. — Carl Woll, Feb 25 '21 at 21:27
But what would you do with the parentheses, even if you could get them in the output? Do you need them visually, or do you have further code that would use them, and how? — MarcoB, Feb 25 '21 at 23:21
@MarcoB I mistakenly thought that including the parentheses would cause each term to have exactly two "parts" or "positions," at which I could then map my two functions over the entire polynomial; now I see that's not the case, and have edited above as necessary. The question was, how to map a function at the "x" part of each term, and then map another function at the "y" part of each term? Example is above. — WQE, Feb 26 '21 at 01:55
I don't know I understand correctly but does this work?
ps2 = Position[eq, _x^_]; MapAt[Test@# &, eq, Join[Complement[ps, Append[#, 1] & /@ ps2], ps2]]``` For `x[1]^2 x[2] + x[1] x[2]^2` output is `Test[x[1]^2] Test[x[2]] + Test[x[1]] Test[x[2]^2]` — Ben Izd, Feb 26 '21 at 07:54
@Beny Izd This is close -- I think you are right that Position will be the key. I can tell my description was not entirely clear; here is a better example. I am often starting with something like (x[1]^4 x[2] + x[1]^3 x[2]^2 + x[1]^2 x[2]^3 + x[1] x[2]^4) y[1] y[2] y[3] y[4] y[5]. Given two functions TestX and TestY, I need to be able to obtain the output TestX[x[1]^4 x[2] + x[1]^3 x[2]^2 + x[1]^2 x[2]^3 + x[1] x[2]^4] * TestY[y[1] y[2] y[3] y[4] y[5]]. I'm working on modifying your idea to get this result ... — WQE, Feb 26 '21 at 15:52

score 1 · Accepted Answer · answered Feb 27 '21 at 09:20

This solution was inspired by this post answered by corey979.

Mathematica has a function called FromCoefficientRules, example:

eq1 = 1 + x[1] + x[2]*y[1] + y[2];
CoefficientRules[eq1]
(Out: {{1, 0, 0, 0} -> 1, {0, 1, 1, 0} -> 1,
        {0, 0, 0, 1} -> 1, {0, 0, 0, 0} -> 1} )

The order of numbers in the keys are based on Variables output:

Variables[e1]
(Out: {x[1], x[2], y[1], y[2]} )

Since you don't want $y$ parts, replace positions of 3 and 4 in the keys to 0:

CoefficientRules[eq1] /. List[x__Integer] :> ReplacePart[List@x, y_ /; y > 2 -> 0]
(Out: {{1, 0, 0, 0} -> 1, {0, 1, 0, 0} -> 1, 
        {0, 0, 0, 0} -> 1, {0, 0, 0, 0} -> 1} )

Now we have two {0, 0, 0, 0} keys in CoefficientRules which will be translated to plain numbers like 1. For removing them use DeleteCases:

DeleteCases[
 CoefficientRules[eq1] /. List[x__Integer] :> ReplacePart[List@x, y_ /; y > 2 -> 0], 
 List[x__Integer] /; Total@List@x == 0 -> _]
(Out: {{1, 0, 0, 0} -> 1, {0, 1, 0, 0} -> 1} )

Use FromCoefficientRules to translate back to normal:

FromCoefficientRules[
 DeleteCases[
  CoefficientRules[eq1] /. List[x__Integer] :> ReplacePart[List@x, y_ /; y > 2 -> 0], 
  List[x__Integer] /; Total@List@x == 0 -> _], Variables[eq1]]

FromCoefficientRules needs variable names, use Variables[eq1] as the second argument.

The above workflow can easily apply to your equation (instead of 4 variables, we have 6, make 4,5,6 zero):

eq2 = 1 + (x[1]^2 x[2] + x[1] x[2]^2 + x[1]^2 x[3] + x[1] x[2] x[3] + 
       x[2]^2 x[3] + x[1] x[3]^2 + x[2] x[3]^2) y[1] y[2] y[3] + 
x[1]^2 x[2]^2 x[3]^2 y[1]^2 y[2]^2 y[3]^2 + 
(-x[1]^2 x[2] x[3] - x[1] x[2]^2 x[3] - x[1] x[2] x[3]^2) y[1] y[2] y[
   3] (y[1] + y[2] + y[3]) + 
(-x[1] x[2] - x[1] x[3] - x[2] x[3]) (y[1] y[2] + y[1] y[3] + y[2] y[3]) + 
x[1] x[2] x[3] (y[1] + y[2] + y[3]) (y[1] y[2] + y[1] y[3] + y[2] y[3]);
xresult = FromCoefficientRules[
 DeleteCases[
  CoefficientRules[eq2] /. 
   List[x__Integer] :> ReplacePart[List@x, y_ /; y > 3 -> 0], 
  List[x__Integer] /; Total@List@x == 0 -> _], Variables[eq2]]
(* for extracting y parts, make 1,2,3 zero*)
yresult = FromCoefficientRules[
 DeleteCases[
  CoefficientRules[eq2] /. 
   List[x__Integer] :> ReplacePart[List@x, y_ /; y <= 3 -> 0], 
  List[x__Integer] /; Total@List@x == 0 -> _], Variables[eq2]]

Outputs:

-3 x[1] x[2] + x[1]^2 x[2] + x[1] x[2]^2 - 3 x[1] x[3] + 
 x[1]^2 x[3] - 3 x[2] x[3] + 10 x[1] x[2] x[3] - 3 x[1]^2 x[2] x[3] + 
 x[2]^2 x[3] - 3 x[1] x[2]^2 x[3] + x[1] x[3]^2 + x[2] x[3]^2 - 
 3 x[1] x[2] x[3]^2 + x[1]^2 x[2]^2 x[3]^2
-3 y[1] y[2] + y[1]^2 y[2] + y[1] y[2]^2 - 3 y[1] y[3] + 
 y[1]^2 y[3] - 3 y[2] y[3] + 10 y[1] y[2] y[3] - 3 y[1]^2 y[2] y[3] + 
 y[2]^2 y[3] - 3 y[1] y[2]^2 y[3] + y[1] y[3]^2 + y[2] y[3]^2 - 
 3 y[1] y[2] y[3]^2 + y[1]^2 y[2]^2 y[3]^2

Now apply your function:

XtoSchur @ xresult
YtoSchur @ yresult

This works very well; many thanks. I just had to modify the code slightly because (a) I need to do the separation term-by-term (rather than for the entire polynomial), and (b) the issue of duplicates becomes more delicate depending on how many subterms there are in the opposite variable; e.g., a polynomial in the $x_i$ multiplied by $(y_1+y_2+y_3)$ creates three copies of each desired term in your xresult. But by first sorting the coefficient list and then using DeleteDuplicatesBywith respect to First, everything seems to work out. — WQE, Feb 27 '21 at 21:37

Carl Woll · Answer 2 · 2021-03-06T06:27:44.447

Why not use 3-arg Collect? For example:

expr = 1 + (x[1]^2 x[2] + x[1] x[2]^2 + x[1]^2 x[3] + x[1] x[2] x[3] + 
   x[2]^2 x[3] + x[1] x[3]^2 + x[2] x[3]^2) y[1] y[2] y[3] + 
x[1]^2 x[2]^2 x[3]^2 y[1]^2 y[2]^2 y[3]^2 + 
(-x[1]^2 x[2] x[3] - x[1] x[2]^2 x[3] - x[1] x[2] x[3]^2) y[1] y[2] y[
   3] (y[1] + y[2] + y[3]) + 
(-x[1] x[2] - x[1] x[3] - x[2] x[3]) (y[1] y[2] + y[1] y[3] + y[2] y[3]) + 
x[1] x[2] x[3] (y[1] + y[2] + y[3]) (y[1] y[2] + y[1] y[3] + y[2] y[3]);
Expand @ Collect[expr, _y, TestX] /. z_TestX w_ :> z TestY[w]

TestX[1] + TestX[-x[1] x[2] - x[1] x[3] - x[2] x[3]] TestY[y[1] y[2]] + TestX[x[1] x[2] x[3]] TestY[y[1]^2 y[2]] + TestX[x[1] x[2] x[3]] TestY[y[1] y[2]^2] + TestX[-x[1] x[2] - x[1] x[3] - x[2] x[3]] TestY[y[1] y[3]] + TestX[x[1] x[2] x[3]] TestY[y[1]^2 y[3]] + TestX[-x[1] x[2] - x[1] x[3] - x[2] x[3]] TestY[y[2] y[3]] + TestX[x[1]^2 x[2] + x[1] x[2]^2 + x[1]^2 x[3] + 4 x[1] x[2] x[3] + x[2]^2 x[3] + x[1] x[3]^2 + x[2] x[3]^2] TestY[y[1] y[2] y[3]] + TestX[-x[1]^2 x[2] x[3] - x[1] x[2]^2 x[3] - x[1] x[2] x[3]^2] TestY[ y[1]^2 y[2] y[3]] + TestX[x[1] x[2] x[3]] TestY[y[2]^2 y[3]] + TestX[-x[1]^2 x[2] x[3] - x[1] x[2]^2 x[3] - x[1] x[2] x[3]^2] TestY[ y[1] y[2]^2 y[3]] + TestX[x[1] x[2] x[3]] TestY[y[1] y[3]^2] + TestX[x[1] x[2] x[3]] TestY[y[2] y[3]^2] + TestX[-x[1]^2 x[2] x[3] - x[1] x[2]^2 x[3] - x[1] x[2] x[3]^2] TestY[ y[1] y[2] y[3]^2] + TestX[x[1]^2 x[2]^2 x[3]^2] TestY[y[1]^2 y[2]^2 y[3]^2]

This seems pretty close, and it's certainly far more elegant; I don't think it's quite what I need, since I need to apply TestX to the entire "x" factor in each monomial while applying TestY to the entire "y" factor in each monomial (and then multiply each resulting pair). So, for example, there shouldn't be any occurrences of TestY[y[1] y[2]] since there were no monomials whose only "y" factor was y[1] y[2]. But this idea looks quite promising; I will have to think about modifying it slightly! — WQE, Mar 07 '21 at 03:14

Map a function at one "part" of each term in a multivariate polynomial

2 Answers2