Replace non-zero elements with symbol

Question

I have a very large matrix (tensor) in Mathematica with some zero and non-zero elements. I am interested in replacing the non-zero elements with some symbol or a 1 so that it is easier to view the entire object.

I would include my code but there is a lot of preamble so here is an analogue of what I would like to work on:

{{{{0, -a Sqrt[a^2 + c^2], -c Sqrt[a^2 + c^2]}, {-a Sqrt[a^2 + c^2], 
 0, 0}, {-c Sqrt[a^2 + c^2], 0, 0}}}, {{{0, 0, 
 0}, {0, -2 a^2, -2 a c}, {0, -2 a c, -2 c^2}}}, {{{0, 0, 0}, {0, 
 0, 0}, {0, 0, 0}}}}

and I would like to output something like:

{{{{0, 1, 1}, {1, 0, 0}, {1, 0, 0}}}, {{{0, 0, 0}, {0, 1, 1}, {0, 1, 
 1}}}, {{{0, 0, 0}, {0, 0, 0}, {0, 0, 0}}}}

Answer 1

I propose the use of ArrayComponents and Unitize:

array = {{{{0, -a Sqrt[a^2 + c^2], -c Sqrt[a^2 + c^2]},
           {-a Sqrt[a^2 + c^2], 0, 0}, {-c Sqrt[a^2 + c^2], 0, 0}}},
         {{{0, 0, 0}, {0, -2 a^2, -2 a c}, {0, -2 a c, -2 c^2}}},
         {{{0, 0, 0}, {0, 0, 0}, {0, 0, 0}}}};

array // ArrayComponents // Unitize

{{{{0, 1, 1}, {1, 0, 0}, {1, 0, 0}}},
 {{{0, 0, 0}, {0, 1, 1}, {0, 1, 1}}},
 {{{0, 0, 0}, {0, 0, 0}, {0, 0, 0}}}}

For the purpose of visualization you may also be interested to know that MatrixPlot and ArrayPlot will handle symbolic element in the following way:

{{0, 0, 0}, {0, -2 a^2, -2 a c}, {0, -2 a c, -2 c^2}} // ArrayPlot

Therefore you could visualize your complete array with something like:

array /. m_?MatrixQ :> ArrayPlot[m] // Grid

Other possibilities exist if you have different needs.

Answer 2

mat = {{{{0, -a Sqrt[a^2 + c^2], -c Sqrt[a^2 + c^2]}, {-a Sqrt[a^2 + c^2], 0, 0},
          {-c Sqrt[a^2 + c^2], 0, 0}}}, 
        {{{0, 0, 0}, {0, -2 a^2, -2 a c}, {0, -2 a c, -2 c^2}}}, 
        {{{0, 0, 0}, {0, 0, 0}, {0, 0, 0}}}}

You can use

f1 = Replace[#, Except[0 | _List] -> 1, Infinity] &;
f2 = SparseArray[SparseArray[#]["NonzeroPositions"] -> 1, Dimensions[#]] &;
f3 = Block[{f}, SetAttributes[f, Listable]; f[0] = 0; f[_] := 1; f@#] &;


f1 @ mat

Equal @@ (Through[{f1, f2, f3}@mat])

True

Answer 3

I used the following code for almost a similar purpose. Hope it also helps you out:

mtx = {{{{0, -a Sqrt[a^2 + c^2], -c Sqrt[a^2 + c^2]}, {-a Sqrt[
    a^2 + c^2], 0, 0}, {-c Sqrt[a^2 + c^2], 0, 0}}}, {{{0, 0, 
  0}, {0, -2 a^2, -2 a c}, {0, -2 a c, -2 c^2}}}, {{{0, 0, 0}, {0,
   0, 0}, {0, 0, 0}}}};

  {Rw, Cl, rw, cl} = Dimensions[mtx];

  Do[
    If[
    mtx[[k, 1, i, j]] =!= 0,
    mtx[[k, 1, i, j]] = 1
    ],
    {k, Rw},
    {i, rw},
    {j, cl}
];

Answer 4

You could also use a Replace that only works at one level instead of all of them (as in @kglr's answer):

Replace[mat, Except[0]->1, {ArrayDepth[mat]}] //TeXForm

$\left( \begin{array}{c} \left( \begin{array}{ccc} 0 & 1 & 1 \\ 1 & 0 & 0 \\ 1 & 0 & 0 \\ \end{array} \right) \\ \left( \begin{array}{ccc} 0 & 0 & 0 \\ 0 & 1 & 1 \\ 0 & 1 & 1 \\ \end{array} \right) \\ \left( \begin{array}{ccc} 0 & 0 & 0 \\ 0 & 0 & 0 \\ 0 & 0 & 0 \\ \end{array} \right) \\ \end{array} \right)$