Converting HeavisideTheta[]s and Sign[]s functions to a single Piecewise[]

Question

I have the product of some Heaviside functions or sign functions, a simple example could be:

HeavisideTheta[q^2 - 4]*Sign[q - 3]

Another slightly more complicated example, involving a quartic function could be:

HeavisideTheta[Sqrt[((q - 3)^2 - 10)^2 + 15] - 8]

Clearly the resulting function will be composed of many steps, so I would like to convert it to a piecewise function. For the example before, the result would be:

Piecewise[{{-1, q <= -2}, {0, -2 < q <= 2}, {-1, 2 <= q < 3}}, 1]

Except for (maybe) a zero measure set, for which I don't care. Many times the variable appears quadratically or quartically inside the functions, so solving to find the zero may be non trivial, but it can always be done exactly by Solve[] or Reduce[].

I need to repeat this procedure a lot of times, so I would like to automate the procedure... Is there a way to teach Mathematica how to do it?

Answer 1

We can use PiecewiseExpand.

ToPiecewise[f_] := PiecewiseExpand[f /. {
  (HeavisideTheta | UnitStep)[x_] :> Piecewise[{{1, x >= 0}, {0, x < 0}}], 
  Sign[x_] :> Piecewise[{{1, x > 0}, {0, x == 0}, {-1, x < 0}}]
}]

On your examples:

ToPiecewise[HeavisideTheta[q^2 - 4]*Sign[q - 3]]
(* Piecewise[{{-1, 2 <= q < 3 || q <= -2}, {1, q > 3}}, 0] *)

ToPiecewise[HeavisideTheta[Sqrt[((q - 3)^2 - 10)^2 + 15] - 8]]
(* Piecewise[{{1, Sqrt[15 + (-10 + (-3 + q)^2)^2] >= 8}}, 0] *)

We can also incorperate Reduce if we supply a variable:

ToPiecewise[f_, z_] := PiecewiseExpand[f /. {
  (HeavisideTheta | UnitStep)[x_] :> Piecewise[{{1, Reduce[x >= 0, z, Reals]}, {0, Reduce[x < 0, z, Reals]}}], 
  Sign[x_] :> Piecewise[{{1, Reduce[x > 0, z, Reals]}, {0, Reduce[x == 0, z, Reals]}, {-1, Reduce[x < 0, z, Reals]}}]
}]

Your example:

ToPiecewise[HeavisideTheta[Sqrt[((q - 3)^2 - 10)^2 + 15] - 8], q]
(* Piecewise[{{1, 3 - Sqrt[3] <= q <=  3 + Sqrt[3] || q >= 3 + Sqrt[17] || q <= 3 - Sqrt[17]}}, 0] *)

Answer 2

You can try solving for the arguments HeavisideTheta and Sign and combine the roots. Since they are in product form root of individual function will also be a root.

Aleternatively you can produce a data set and find the Interpolation like

data = Table[{q, HeavisideTheta[q^2 - 4]*Sign[q - 3]}, {q, -4, 4, .1}];
f = Interpolation[data];
Plot[f[x], {x, -4, 4}]
FindRoot[f[x] == 0, {x, 3}]

You can't use Solve because your function, due to the HeavisideTheta will be 0 over a region which means infinite solution. So only significant solution will come from the argument of Sign which will give the point where your function cut the zero axis (provided HeavisideTheta is not zero there). FindRoot would be more efficient choice but you have to be careful about the initial value, or else you may be lost forever.

Answer 3

I do admit that it's pretty ugly but here is an approach:

expr[q_] := HeavisideTheta[q^2 - 4]*Sign[q - 3]
bounds = Sort@Flatten[expr[q] /. 
  Times[a_, b_] :> {a, b} /. 
  {HeavisideTheta[a_] :> Re /@ N@Solve[a == 0, First@Variables@a][[All, 1, 2]], 
   Sign[Plus[a_, b_]] :> Abs@a, Sign[_] :> 0}];
b = Flatten[{{Prepend[{bounds[[1]]}, x]}, 
  Riffle[bounds[[#]], x] & /@ 
    Partition[Delete[Delete[Flatten[{#, #} & /@ Range@Length@bounds], -1], 1], 2]}, 1];
lb = LessEqual @@@ b;
oob = With[{l = Cases[#, _?NumberQ]}, If[Length@l < 2, Flatten@{2*l, l}, l]] &;
value = With[{q = #}, expr[q]] & /@ (RandomReal[#] & /@ oob /@ b);

Show@{
  Plot[expr@x, {x, -5, 5}, PlotStyle -> {Red, Dotted, Thick}],
  Plot[Piecewise[{#1, #2} & @@@ Thread[{value, lb}], 
    HeavisideTheta@Last@bounds], {x, -5, 5}, PlotStyle -> Dashed]}

With

expr[q_] := HeavisideTheta[Sqrt[((q - 3)^2 - 10)^2 + 15] - 8]*Sign[-3 + q];