4
$\begingroup$

Suppose I have a list of simple expressions, something like:

list = {{a-b-2c-d+e+2f},{-a-2b-c+d+2e+f},{-2a-b+c+2d+e-f},{x-y-z},{-x+y-z},{-x-y+z}};

These expressions are going to become elements in a linear combination. But notice that the third element in this list is itself already a linear combination of the first two. Therefore, my "basis" really should be this list without one of the first three elements (it doesn't matter which one goes away, but for consistency I would like to remove the third of them). Is there an automated way in Mathematica to search a list of expressions like this, identify when elements are linear combinations of others, and then remove the extraneous elements?

$\endgroup$
  • 2
    $\begingroup$ "But notice that the third element in this list is itself already a linear combination of the first two." Nope. Check it (especially $e$). $\endgroup$ – David G. Stork Nov 12 '18 at 5:49
  • $\begingroup$ Yeah, typo. Fixed now. Thank you for pointing it out! $\endgroup$ – Kevin Ausman Nov 13 '18 at 19:53
2
$\begingroup$

Take your list and fix it so that the 3rd element dependent on the first two:

list[[3]] = (list[[2]] + list[[1]])/3 // Expand;
list
(*
  {{2a + b - c - 2d - e + f}, {a + 2b + c - d - 2 e - f}, {-a + b + 2c + d - e - 2f},
   {x - y - z}, {-x + y - z}, {-x - y + z}}
*)

Convert system of linear functions to a matrix:

vars = Variables@list;
linsys = CoefficientArrays[Flatten@list, vars][[2]];

Extract linearly independent elements of list:

Extract[list, 
 FirstPosition[#, 1, Nothing] & /@ RowReduce[Transpose@linsys]]
(*
  {{a - b - 2 c - d + e + 2 f}, {-a - 2 b - c + d + 2 e + f},
   {x - y - z}, {-x + y - z}, {-x - y + z}}
*)

Or row reduce to get an equivalent basis:

RowReduce[linsys].vars // DeleteCases[0]
(*  {a - c - d + f, b + c - e - f, x, y, z}  *)
$\endgroup$
  • $\begingroup$ The example I started with does have the third entry dependent on the first two (element 2 minus element 1 is element 3). But regardless, your approach worked perfectly! Thank you! $\endgroup$ – Kevin Ausman Nov 12 '18 at 19:13
  • $\begingroup$ @KevinAusman You're welcome. (Maybe there's a typo in the question because elt. 2 minus elt. 1 should have a + e in the expression, but there are no e.) $\endgroup$ – Michael E2 Nov 12 '18 at 19:40
  • $\begingroup$ Huh. You are obviously correct about the typo. Thank you! Fixing it now. $\endgroup$ – Kevin Ausman Nov 13 '18 at 19:47
  • $\begingroup$ And I accidentally, in trying to fix the problem, tried to edit your response! So sorry... I don't know how to withdraw my suggested edit. Clearly I didn't get enough sleep last nigh. $\endgroup$ – Kevin Ausman Nov 13 '18 at 19:51
  • $\begingroup$ @KevinAusman No problem. New users' edits of other posts go through a queue for approval. Those who review it might reject it, if they spot the error. If it does go through, it can be rolled back. Hopefully they will see your comment and reject it. $\endgroup$ – Michael E2 Nov 13 '18 at 19:55
3
$\begingroup$

What I would do is replace symbols by numeric vectors with a function like

ClearAll[toNumbers];
toNumbers[list_, vars_] := 
  list /. Thread[vars -> IdentityMatrix[Length[vars]]];

toNumbers[{a, b, a + b}, {a, b}]
(*{{1, 0}, {0, 1}, {1, 1}}*)

then perform some linear algebra and convert the result back into symbols with something like

ClearAll[fromNumbers];
fromNumbers[list_, vars_] := Replace[
 list,
 x_ :> x.vars,
 {1}
];

fromNumbers[{{1, 0}, {0, 1}, {1, 1}}, {a, b}]
(*{a, b, a + b}*)

The linear algebra logic can be something like Fold which checks a vector and appends it to a list if it is linear independent form the vectors in the list:

Fold[
 f,
 {},
 {{1, 1, 0}, {0, 1, 0}, {1, 1, 1}}
]

where

ClearAll[f];
f[vecs_, vec_] := With[
   {
    vecs2 = Append[vecs, vec]
   },
   vecs2 /; MatrixRank[vecs2] == Length[vecs2]
];
f[vecs_, vec_] := vecs;

Gathering all together (except f):

ClearAll[leaveLinearIndependent];
leaveLinearIndependent[list_, vars_] := Replace[
  Fold[
   f,
   {},
   list /. Thread[vars -> IdentityMatrix[Length[vars]]]
   ],
 x_ :> x.vars,
 {1}
 ];

leaveLinearIndependent[{a, a + b, b, c}, {a, b, c}]
(*{a, a + b, c}*)
$\endgroup$
2
$\begingroup$
list = {{a-b-2c-d+e+2f},{-a-2b-c+d+2e+f},
  {-2a-b+c+2d+e-f},{x-y-z},{-x+y-z},{-x-y+z}};

First extract coefficient arrays.

coeffArrays = Normal[CoefficientArrays[list]][[2,All,1]]               

(* ut[29]= {{1, -1, -2, -1, 1, 2, 0, 0, 0},
   {-1, -2, -1, 1, 2, 1, 0, 0, 0}, 
   {-2, -1, 1, 2, 1, -1, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 1, -1, -1}, 
   {0, 0, 0, 0, 0, 0, -1, 1, -1}, {0, 0, 0, 0, 0, 0, -1, -1, 1}} *)

Find null vectors of the transpose.

nulls = NullSpace[Transpose@dd]                                        

(* Out[30]= {{1, -1, 1, 0, 0, 0}} *)

We want to remove vectors in positions of last nonzero value in each null vector (of which there is but one, in this case). We can automate the task of finding the list to remove as below.

Flatten[Length[nulls[[1]]] + 1 -
    Map[FirstPosition[#,Except[0],Heads->False]&,
      Map[Reverse,nulls]]]                                               

(* Out[41]= {3} *)
$\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.