How to sort arguments of Times in nonstandard order?

Question

Is there an elegant way to sort the arguments of Times in e.g. TraditionalForm so that factors go to the front and state variables to the back? Are there methods to prevent certain transformations, like moving everything into the numerator as in the example?

par = {p, k, Subscript[k, a], Subscript[k, b]};
expr = -A Subscript[k, b] B p k (1 - p) 1/(B + A) Subscript[k, a]

$-\frac{A \ B \ k \ (1-p) \ p \ k_a \ k_b}{A+B}$

What I would like to see is that symbols are ordered according to their appearance order in par, symbols not specified are sent to the back and fractions are not transformed at all, something like this:

$-(1-p) \ p \ k \ k_a \ k_b \ \frac{1}{A+B} \ A \ B$

There are many problems when manually sorting arguments of Times (here I only did a reversal for sake of simplicity):

expr /. Times[x_, y__] :> ((Inactive@Times) @@ Reverse[{x, y}])

$k_b*k_a*p*(1-p)*k*\frac{1}{A+B}*B*A*-1$

for example unnecessary *-s and numerical factors like -1 explicitly displayed.

Answer 1

You can create your own ...Form wrapper that will format Times as you want it.

Let's start with ordering function that can be used in SortBy. It puts numeric coefficients in front, expressions present in par are ordered according to their position in par, all other expressions are moved to the end.

ClearAll[par, order]
par = {(1 - p), p, k, Subscript[k, a], Subscript[k, b]};
order[_?NumericQ] := 0
order[x_] := Replace[Position[par, x, {1}, 1], {{i_}} :> i]

Now a small helper "wrapper" that will vanish after conversion to boxes. It will also remove boxes resulting from HoldForm used directly inside wrapper.

ClearAll[vanishingWrapper]
MakeBoxes[vanishingWrapper[expr_], form_] ^:= MakeBoxes[expr, form];
MakeBoxes[vanishingWrapper[HoldForm[expr_]], form_] ^:= 
    First@MakeBoxes[HoldForm[expr], form];

Now the main ...Form function that, when converted to boxes, wraps some sub-expressions with our vanishingWrapper:

ClearAll[istvanForm]
MakeBoxes[istvanForm[expr_], _] ^:=
    With[
        {heldExpr =
            HoldComplete[expr] /. HoldPattern[Times][args__] :>
                With[
                    {eval =
                        With[
                            {heldArgs = 
                                Replace[
                                    SortBy[HoldComplete[args], order], 
                                    pow_Power :> vanishingWrapper[pow],
                                    {1}
                                ]}
                            ,
                            Function[Null,
                                vanishingWrapper@HoldForm@Times[##], 
                                HoldAllComplete
                            ] @@ heldArgs
                        ]}
                    ,
                    eval /; True
                ]}
        ,
        Function[Null, MakeBoxes[#, TraditionalForm], HoldAllComplete] @@
            heldExpr
    ]

When Times function is converted to TraditionalForm boxes, its arguments are sorted, unless Times is inside HoldForm. This sorting is done in addition to ordinary sorting, occurring due to Orderless attribute, when Times is evaluated. To prevent this additional sorting, istvanForm wraps Times with HoldForm and vanishingWrapper. So we get boxes coming from HoldForm[Times[...]], but thanks to vanishingWrapper all additional boxes from HoldForm are gone, so when we copy resulting expression there will be no HoldForm inside it.

When Power expression, with negative numeric exponent, is found directly inside Times, it triggers special formatting rules putting everything in one fraction. To prevent this special formatting, istvanForm wraps all Power expressions on first level of Times with vanishingWrapper. So that, when expression is converted to boxes, special formatting is not triggered.

To make istvanForm behave like proper ...Form wrapper we must add it to $OutputForms:

If[FreeQ[$OutputForms, #, {1}],
Unprotect@$OutputForms;
    PrependTo[$OutputForms, #];
Protect@$OutputForms;
]& @ istvanForm

Now let's see istvanForm in action:

-A Subscript[k, b] B p k (1 - p) 1/(B + A) Subscript[k, a] // istvanForm

Answer 2

I shall adapt my code from How do I reassign canonical ordering of symbols? with the addition of a rule for the Power[_, -1] form. I assume that any Variables not in par are to be placed at the end.

reorderIstván[expr_, par_List] :=
 Module[{h, rls},
   rls = MapIndexed[x : # :> h[#2, Replace[x, rls, -1]] &, 
     DeleteDuplicates @ Join[par, Variables @ expr] ];
   HoldForm @@ {expr /. rls} //. h[_, x_] :> x /. 
    x_^-1 :> RawBoxes @ FractionBox["1", ToBoxes[x]]
 ]

Now:

par = {p, k, Subscript[k, a], Subscript[k, b]};
expr = -A Subscript[k, b] B p k (1 - p) 1/(B + A) Subscript[k, a];

reorderIstván[expr, par]

-(1 - p) p k Subscript[k, a] Subscript[k, b] A B 1/(A + B)

reorderIstván[expr, par] // TeXForm

$-(1-p) p k k_a k_b A B \frac{1}{A+B}$