2
$\begingroup$

My problem is the following:

Suppose I have a matrix A which looks the following:

A = {{1, 2, 0, 0, 0}, {2, 3, 0, 1, 0}, {3, 4, 1, 0, 0},
     {5, 6, 0, 0, 1}, {6, 7, 0, 0, 0}}

What I want Mathematica to do is to drop or delete an entire row if the sum of columns 3,4&5 of that specific row is equal to zero.

E.g. A[[1]] should be dropped because the sum of the last three elements of this row is zero. Same for the last row of matrix A.

I tried the following but it's not working, and I don't know whether it's my fault or whether Mathematica encountered a problem with that specific case:

A2 = Do[If[
   Transpose[A][[3]][[i]] + Transpose[A][[4]][[i]] + 
     Transpose[A][[5]][[i]] = 0, Drop[A[[n]]]], {i, 
   Length[Transpose[A][[1]]]}]
A

Set::write: Tag Plus in 0+0+0 is Protected.

Set::write: Tag Plus in 0+0+1 is Protected.

Set::write: Tag Plus in 0+0+1 is Protected.

General::stop: Further output of Set::write will be suppressed during this calculation.

{{1, 2, 0, 0, 0}, {2, 3, 0, 1, 0}, {3, 4, 1, 0, 0}, {5, 6, 0, 0, 1}, {6, 7, 0, 0, 0}}

$\endgroup$
  • 2
    $\begingroup$ Use Equal (==) to test for equality, not Set (=) $\endgroup$ – Simon Woods Jun 25 '14 at 12:42
5
$\begingroup$
A = {{1, 2, 0, 0, 0}, {2, 3, 0, 1, 0}, {3, 4, 1, 0, 0}, {5, 6, 0,0, 1}, {6, 7, 0, 0, 0}};
Select[A, Total@#[[3 ;; 5]] != 0 &]
Cases[A, _?(Total@#[[3 ;; 5]] != 0 &)]

{{2, 3, 0, 1, 0}, {3, 4, 1, 0, 0}, {5, 6, 0, 0, 1}}

$\endgroup$
  • $\begingroup$ Also DeleteCases[A, {x_, y_, z__ /; Total[{z}] == 0} ]. $\endgroup$ – b.gates.you.know.what Jun 25 '14 at 12:45
  • 2
    $\begingroup$ @b.gatessucks, or DeleteCases[A, {_, _, z__ /; +z == 0}] $\endgroup$ – Simon Woods Jun 25 '14 at 12:49
  • $\begingroup$ @SimonWoods Learnt something new, thanks ! $\endgroup$ – b.gates.you.know.what Jun 25 '14 at 12:52
5
$\begingroup$

Error

I addressed the cause of this error message here:

Using findBadSets from the second one will return:

Plus     Transpose[hallo][[3]][[i]]+Transpose[hallo][[4]][[i]]+Transpose[hallo][[5]][[i]]

which indicates the error.

Solutions

As to the solution to your problem here is another option:

Select[A, #3 + #4 + #5 != 0 & @@ # &]

Or assuming all positions to add are contiguous at the end of the subset:

Select[A, +##3 != 0 & @@ # &]

For better performance I suggest this variation of the Pick solutions:

Pick[A, A[[All, {3, 4, 5}]] ~Total~ {2} // Unitize, 1]

Timings

Timings for all methods posted so far:

SetAttributes[timeAvg, HoldFirst]
timeAvg[func_] := Do[If[# > 0.3, Return[#/5^i]] & @@ Timing@Do[func, {5^i}], {i, 0, 15}]

A = a = RandomInteger[6, {500000, 5}];

Select[A, Total@#[[3 ;; 5]] != 0 &]                    // timeAvg
Cases[A, _?(Total@#[[3 ;; 5]] != 0 &)]                 // timeAvg

Pick[a, Total[#[[-3 ;;]]] != 0 & /@ a]                 // timeAvg
Pick[a, Tr@# != 0 & /@ a[[All, -3 ;;]]]                // timeAvg
DeleteCases[a, _?(Total[#[[-3 ;;]]] == 0 &)]           // timeAvg
If[Total[#[[-3 ;;]]] == 0, ## &[], #] & /@ a           // timeAvg
a /. x : {__} /; Total[x[[-3 ;;]]] == 0 :> Sequence[]  // timeAvg

Pick[A, Unitize[+##3 & @@@ A], 1]                      // timeAvg
Pick[A, +##3 != 0 & @@@ A]                             // timeAvg

Select[A, #3 + #4 + #5 != 0 & @@ # &]                  // timeAvg
Pick[A, A[[All, {3, 4, 5}]] ~Total~ {2} // Unitize, 1] // timeAvg
0.796
0.889
0.843
0.421
0.92
0.921
1.606
0.328
0.452
0.733
0.0842
$\endgroup$
4
$\begingroup$

Just another Pick variant (Unitize in case nonzero sum !=1...test case not needed):

Pick[A, Unitize[Plus@##3 & @@@ A], 1] 
$\endgroup$
  • 1
    $\begingroup$ Nice use of SlotSequence. Shorter version: Pick[A,+##3!=0&@@@A] $\endgroup$ – Simon Woods Jun 25 '14 at 13:31
  • $\begingroup$ @SimonWoods thank you...like your neat shorter version...gets to heart with Boolean...no unitized, third argument $\endgroup$ – ubpdqn Jun 25 '14 at 13:39
  • $\begingroup$ I agree Simon's code is particularly nice, but yours is somewhat faster. However, for packed arrays at least neither is optimal -- it is better to use Part and Total to prevent unpacking. $\endgroup$ – Mr.Wizard Jun 25 '14 at 13:45
  • $\begingroup$ @Mr.Wizard, one is so often torn between terseness and efficiency :-) My dream is one day to find a language in which the shortest code is always the fastest... $\endgroup$ – Simon Woods Jun 25 '14 at 13:53
  • $\begingroup$ @SimonWoods Let me know if you find it! Mathematica is usually pretty good there as pushing things into optimized kernel functions is typically fast. Disappointment happens when kernel functions are not as fast as other parts of the system and I end up carting around SparseArray[. . .]["AdjacencyLists"] as a substitute for Position, etc. $\endgroup$ – Mr.Wizard Jun 25 '14 at 13:56
2
$\begingroup$
a = {{1, 2, 0, 0, 0}, {2, 3, 0, 1, 0}, {3, 4, 1, 0, 0}, {5, 6, 0, 0,  1}, 
    {6, 7, 0, 0, 0}};

Pick[a, Total[#[[-3 ;;]]] != 0 & /@ a]

or

Pick[a, Tr@# != 0 & /@ a[[All, -3 ;;]]]

or

DeleteCases[a, _?(Total[#[[-3 ;;]]] == 0 &)]

or

If[Total[#[[-3 ;;]]] == 0, ## &[], #] & /@ a

or

a /. x : {__} /; Total[x[[-3 ;;]]] == 0 :> Sequence[]

all give

(* {{2, 3, 0, 1, 0}, {3, 4, 1, 0, 0}, {5, 6, 0, 0, 1}} *)
$\endgroup$
1
$\begingroup$

Dot is typically faster than Total, so the following variation is significantly faster than the fastest previous solution (by Mr.Wizard):

A = RandomInteger[6, {500000,5}];

r1 = Pick[A, A[[All, {3, 4, 5}]] ~Total~ {2} // Unitize, 1]; //RepeatedTiming
r2 = Pick[A, A . {0, 0, 1, 1, 1} //Unitize, 1]; //RepeatedTiming

r1 === r2

{0.038, Null}

{0.022, Null}

True

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