Visually permute rows of a matrix via mouse dragging

Question

I'm looking for a way to permute the rows of a matrix visually via mouse dragging, for example by clicking and dragging on a row in the MatrixPlot corresponding to the matrix.

What would be the best way to achieve something like this? By best I here mean in terms of efficiency and readability/scalability of implementation.

Answer 1

EDIT: converted the use of explicit Hold wrappers to appropriate HoldAll and HoldFirst attributes of helper functions. Also added possibility to change columns together with rows, and added highlighting of rows/columns that are being moved.

The following is a possible implementation, allowing to visually switch neighbouring rows and columns via mouse dragging the corresponding MatrixPlot of the matrix.

If a symbol containing a matrix is passed to the function, the value of the matrix is changed in-place, so that this can be thought of as a way to visually change a matrix.

To start, I defined an helper function MP, which is nothing but a MatrixPlot with some commonly used options:

(* MP is just a shorthand for MatrixPlot, with some predefined commonly used
   options *)
Options @ MP = Options @ MatrixPlot;
MP[expr_, opts : OptionsPattern[]] := MatrixPlot[
  expr,
  Evaluate @ FilterRules[{opts}, Options @ MatrixPlot],
  PlotRangePadding -> None,
  Mesh -> All, MeshStyle -> Gray
];

The code implementing the functionality is then the following:

rowNumber[matrix_] := If[# === None, #,
  If[
    MatchQ[#, _Integer ? (1 <= # <= Length @ matrix &)],
    #, None
  ] & [
    1 + Length @ matrix - Last @ Floor[# + 1]
  ]
] & @ MousePosition["Graphics"];


colNumber[matrix_] := If[# === None, #,
  If[
    MatchQ[#, _Integer ? (1 <= # <= Last @ Dimensions @ matrix &)],
    #, None
  ] & [
    First @ Floor[# + 1]
  ]
] & @ MousePosition["Graphics"];


mouseOnGraphics[] := MousePosition["Graphics"] =!= None;


switchRows[matrix_, row1_, row2_] := ReplacePart[matrix,
  {row1 -> matrix[[row2]],
   row2 -> matrix[[row1]]}
];


switchCols[matrix_, col1_, col2_] := ReplacePart[matrix,
  {
    {row_, col1} :> matrix[[row, col2]],
    {row_, col2} :> matrix[[row, col1]]
  }
];


(* Replace neighboring rows or columns, conditionally to the value of `which`.
   The change is done in-place, that is, the value of `matrixVar` is changed
   directly. *)
Attributes @ switchNeighborsInPlace = HoldFirst;
switchNeighborsInPlace[
  matrixVar_, idx1_, idx2_, which : ("Rows" | "Cols")
] := Set[matrixVar,
  Which[
    which == "Cols",
    switchCols[matrixVar, idx1, idx2],
    which == "Rows",
    switchRows[matrixVar, idx1, idx2]
  ]
];


Attributes @ conditionallySwitchNeighbors = HoldAll;
conditionallySwitchNeighbors[
  matrix_, labelsList_, oldIdx_, newIdx_, which : ("Rows" | "Cols")
] := If[
  Abs[oldIdx - newIdx] == 1 // TrueQ,
  switchNeighborsInPlace[matrix, oldIdx, newIdx, which];
  labelsList[[{oldIdx, newIdx}]] = labelsList[[{newIdx, oldIdx}]];
  oldIdx = newIdx
];


drawHighlightingRectangles[len_, row_, col_] := {
  FaceForm[], EdgeForm[{Red, Thickness @ 0.01}],
  If[NumericQ @ row,
    Rectangle[{0, len - row}, {len, len - row + 1}],
    Sequence[]
  ],
  FaceForm[], EdgeForm[{Purple, Thickness @ 0.01}],
  If[NumericQ @ col,
    Rectangle[{col - 1, 0}, {col, len}],
    Sequence[]
  ]
};


makeFrameTicks[len_Integer, labels_List] := {
  {#, #}, {#, #}
} & @ Thread @ {Range @ len, labels};

makeFrameTicks[lenghts_List, labelsRows_List, labelsCols_List] := {
  {#1, #1}, {#2, #2}
} & [
  Thread @ {Range @ lenghts[[1]], labelsRows},
  Thread @ {Range @ lenghts[[2]], labelsCols}
];

makeFrameTicks[labels_List] := makeFrameTicks[Length @ labels, labels];
makeFrameTicks[labelsRows_List, labelsCols_List] := makeFrameTicks[
  Length /@ {labelsRows, labelsCols}, labelsRows, labelsCols
];


Attributes @ dynamicMatrixPlot = HoldFirst;

Options @ dynamicMatrixPlot = {"OverlayRectangles" -> False};

dynamicMatrixPlot[matrix_, opts : OptionsPattern[]] := If[
  (* If the input is directly given as a matrix, we make local variable holding
     it and recall the function with that variable as argument *)
  ! MatchQ[Hold @ matrix, Hold @ _Symbol],
  Module[{mat = matrix}, dynamicMatrixPlot[mat, opts]],

  With[{overlayRectangles = TrueQ @ OptionValue @ "OverlayRectangles"},
  DynamicModule[{
      len = Length @ matrix,
      oldRow, oldCol,
      rowsOrder = Range @ Length @ matrix,
      colsOrder = Range @ Length @ matrix
    },
    EventHandler[
      Dynamic @ MP[matrix,
        (* Epilog is used to draw the rectangles highlighting the row/column
           that is being moved *)
        If[overlayRectangles,
          Epilog -> drawHighlightingRectangles[len, oldRow, oldCol],
          Unevaluated @ Sequence[]
        ],
        FrameTicks -> makeFrameTicks @@ {rowsOrder, colsOrder}
      ],
      {
        "MouseDown" :> (
          Set[oldRow, rowNumber @ matrix];
          Set[oldCol, colNumber @ matrix]
        ),
        "MouseDragged" :> (
          If[And[
              mouseOnGraphics[],
              rowNumber @ matrix =!= None,
              colNumber @ matrix =!= None
            ],
            (* conditionallySwitchNeighbors handles the switching of neighboring
               rows and columns. Note that it also changes in-place `oldRow`
               and `oldCol`. *)
            conditionallySwitchNeighbors[
              matrix, rowsOrder, oldRow, rowNumber @ matrix, "Rows"
            ];
            conditionallySwitchNeighbors[
              matrix, colsOrder, oldCol, colNumber @ matrix, "Cols"
            ]
          ];
        )
      }
    ]
  ]]
];

The main idea is pretty simple: MP (or, equivalently, MatrixPlot) is used to draw the matrix, and an EventHandler wraps the whole MP handling the MouseDown and MouseDragged events.

To use it just call dynamicMatrixPlot over the target matrix:

The function can also be used to modify a pre-existing matrix:

matrix = HamadardMatrix @ 4;
dynamicMatrixPlot @ matrix

will change matrix to be what is currently shown in the plot.

The implementation is surely not optimal. In particular, when the kernel is quitted the plots disappear, basically because MP and the local variables created by Module are not defined anymore. I'm not sure how to fix this though, suggestions are welcome!