3
$\begingroup$

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}}}}
$\endgroup$
5
$\begingroup$

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

enter image description here

Therefore you could visualize your complete array with something like:

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

enter image description here

Other possibilities exist if you have different needs.

$\endgroup$
3
$\begingroup$
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

Mathematica graphics

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

True

$\endgroup$
1
$\begingroup$

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}
];
$\endgroup$
1
$\begingroup$

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)$

$\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.