3
$\begingroup$

I'm trying to solve for $\|A(a)\|_\infty=1$ where $A$ is a positive definite matrix parameterized by scalar $a$ and $\|.\|_\infty$ is max-row-sum norm of the matrix.

For the problem below, I know the answer is $2/7$ which can be obtained using NMaximize, meanwhile Reduce and Solve fail to simplify into 2/7. It looks like Max causes a problem for these functions.

Any tips how to make equations in terms of max-row-sum norm palatable to Mathematica?

mat = {{1 - 2 a + 3 a^2, 2 a^2}, {2 a^2, 1 - 4 a + 12 a^2}};
maxrowsum[mat_] := Max[Total[Abs[#]] & /@ mat];
(a /. Last[
   NMaximize[{maxrowsum[mat], maxrowsum[mat] <= 1}, 
    a]])  (*works*)
Assuming[{a > 0}, Solve[maxrowsum[mat] == 1, a]] (* fails *)
$\endgroup$
1
  • $\begingroup$ Note maxrowsum[mat] is the same as Norm[mat, 1], though that does not help the main problem. $\endgroup$
    – Michael E2
    Oct 15 '20 at 2:24
3
$\begingroup$

Adding the domain Reals allows Solve to work:

Solve[maxrowsum[mat] == 1, a, Reals]
{{a -> 0}, {a -> 2/7}}
$\endgroup$
1
  • $\begingroup$ Aha, that's the trick I needed! Turning it into linear programming is nice, but way too much work when I just need an answer fast :) $\endgroup$ Oct 15 '20 at 3:10
3
$\begingroup$

You can set it up almost like a LP problem.

mat = {{1 - 2 a + 3 a^2, 2 a^2}, {2 a^2, 1 - 4 a + 12 a^2}};
dims = Dimensions[mat];
vars = Array[x, dims];
c1 = Flatten[
   Table[{vars[[i, j]] >= mat[[i, j]], 
     vars[[i, j]] >= -mat[[i, j]]}, {i, dims[[1]]}, {j, dims[[2]]}]];
c2 = Table[Total[vars[[i]]] <= 1, {i, dims[[1]]}];
c3 = Append[Thread[max >= Total[Transpose[vars]]], max <= 1];

constraints = Join[c1, c2, c3]
allvars = Flatten[{vars, max}]

In[563]:= constraints = Join[c1, c2, c3]

allvars = Flatten[{vars, max}]

(* Out[563]= {x[1, 1] >= 1 - 2 a + 3 a^2, x[1, 1] >= -1 + 2 a - 3 a^2, 
 x[1, 2] >= 2 a^2, x[1, 2] >= -2 a^2, x[2, 1] >= 2 a^2, 
 x[2, 1] >= -2 a^2, x[2, 2] >= 1 - 4 a + 12 a^2, 
 x[2, 2] >= -1 + 4 a - 12 a^2, x[1, 1] + x[1, 2] <= 1, 
 x[2, 1] + x[2, 2] <= 1, max >= x[1, 1] + x[1, 2], 
 max >= x[2, 1] + x[2, 2], max <= 1}

Out[564]= {x[1, 1], x[1, 2], x[2, 1], x[2, 2], max} *)

Now use Maximize.

Maximize[{a, constraints}, Join[allvars, {a}]]

(* Out[554]= {2/7, {x[1, 1] -> 3/4, x[1, 2] -> 13/64, x[2, 1] -> 8/49, 
  x[2, 2] -> 41/49, max -> 1, a -> 2/7}} *)
$\endgroup$
3
$\begingroup$

Alternatively set it up as a univariate minimization and use calculus to solve exactly. We use the usual sqrt(x^2) to form abs(x) and insist that the product of squared differences of rownorms from 1 be zero. Since this is a product of squares we use calculus to find candidate minima.

mat = {{1 - 2 a + 3 a^2, 2 a^2}, {2 a^2, 1 - 4 a + 12 a^2}};
rownorms = Total[Sqrt[Transpose[mat]^2]];
obj = Apply[Times, (rownorms - 1)^2]
expr = Together[PowerExpand[Together[D[obj, a]], Assumptions -> a > 0]]

(* Out[666]= (-1 + 2 Sqrt[a^4] + Sqrt[(1 - 2 a + 3 a^2)^2])^2 (-1 + 
   2 Sqrt[a^4] + Sqrt[(1 - 4 a + 12 a^2)^2])^2

Out[667]= 32 (8 a^3 - 120 a^4 + 642 a^5 - 1470 a^6 + 1225 a^7) *)

Find candidate solutions.

candidates = Union[Flatten[Solve[expr == 0, a]]]

(* Out[668]= {a -> 0, a -> 2/7, a -> 2/5, a -> 1/35 (9 - Sqrt[11]), 
 a -> 1/35 (9 + Sqrt[11])} *)

Select any that actually do make the objective minimal (zero) and moreover give a max rownorm of 1.

Select[candidates, ((obj /. #) == 0) && (Max[rownorms /. #] <= 1) &]

(* Out[669]= {a -> 0, a -> 2/7} *)
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.