I have a notebook bloated by graphics and would like to delete many of them. To do this I would like an expression to find the next graphic. I tried:
NotebookFind[SelectedNotebook[], "Graphics", Next, CellStyle] But that did not work.
$\begingroup$ $\endgroup$
4 
- $\begingroup$ Sigh. I fiddled with this and don't have a good answer. However, there are a couple things that might satisfy you. First, if you Option-Click the cell bracket (blue thing on the right edge), all cells of the same type will be selected. I do this to clean things up. I Option-Click an output cell and then tap the Delete key. So, not graphics specific, but maybe it'll be good enough. $\endgroup$lericr– lericr2022-02-25 19:33:57 +00:00Commented Feb 25, 2022 at 19:33
- $\begingroup$ Second, if you know something about the input that created the outputs you want to delete, you might be able to do something like this: NotebookFind[EvaluationNotebook[], "Plot", Next, WrapAround -> True]; SelectionMove[EvaluationNotebook[], Next, Cell]. Yeah, that's going require you to do one at a time. $\endgroup$lericr– lericr2022-02-25 19:34:10 +00:00Commented Feb 25, 2022 at 19:34
- $\begingroup$ Third, you can mark input cells as not evaluatable (Cell menu->Cell Properties). So, if you're in the habit of selecting everything and evaluating, this will suppress output of cells that you're not currently interested in. $\endgroup$lericr– lericr2022-02-25 19:41:57 +00:00Commented Feb 25, 2022 at 19:41
- $\begingroup$ Fourth (this can be a bit scary), you can expose the internals of cells by selecting a cell and doing a Command-Shift-E (or whatever the equivalent is on your machine). Same command toggles it back. So, go to a "bad" cell, expose its textual representation, and find something that you could do a text search on (like maybe "GraphicsBox"). Now, select everything in your notebook and do the command so they're all exposed. Now in a new Input cell do something like NotebookFind[EvaluationNotebook[], "GraphicsBox", All]. Delete them all. Now select all and toggle back to normal display. $\endgroup$lericr– lericr2022-02-25 19:49:13 +00:00Commented Feb 25, 2022 at 19:49
Add a comment |
1 Answer
$\begingroup$
Efficient way to find and select next
$\endgroup$
How to find next graphic
In principle, SelectionMove[nb, Next, Graphics] does this, but it works only if the selection is already inside of a Cell. And unfortunately, it doesn't return $Failed when there is no graphics, and SelectionMove can't move the selection (this is a bug, reported as [CASE:4909617]).
It could be used as follows:
(* Create a notebook *) nb = CreateWindow[ DocumentNotebook[ CellGroup[{TextCell["Graphics Group", "Section"], ExpressionCell[RandomImage[1, {200, 200}], "Output"], ExpressionCell[Plot[Exp[-x^2], {x, -3, 3}], "Output"]}, Closed]]]; (* Select graphics in the second cell *) SelectionMove[nb, Next, Cell, 2]; SelectionMove[nb, Before, CellContents]; SelectionMove[nb, Next, Graphics]; We can check whether something is selected with NotebookRead[nb] or with "CursorPosition" /. Developer`CellInformation[nb]. But this whole approach is highly inefficient, has an undesirable side-effect (opening cell group even if the group doesn't contain graphics), and also feels not completely reliable due to buggy SelectionMove.
Efficient way to find and select next graphic without processing the whole Notebook
We can implement selectNextGraphics as follows:
cellContainsGraphicsQ[cellObj_CellObject] := Head[FirstPosition[NotebookRead@cellObj, _GraphicsBox]] =!= Missing; findNextCellWithGraphics[None] = None; findNextCellWithGraphics[cellObj_CellObject] := Module[{cobj = cellObj}, While[Head[cobj] === CellObject && ! cellContainsGraphicsQ[cobj], cobj = NextCell[cobj]]; cobj]; selectNextGraphicsInCell[None] = None; selectNextGraphicsInCell[cellObj_CellObject] := Module[{cp = "CursorPosition" /. Developer`CellInformation[cellObj]}, If[MatchQ[cp, "CellBracket" | None], SelectionMove[cellObj, Before, CellContents]]; SelectionMove[ParentNotebook[cellObj], Next, Graphics]; If[MatchQ[ "CursorPosition" /. Developer`CellInformation[cellObj], {{0, 0}} | cp], $Failed]]; selectNextGraphics[nb_NotebookObject] := Module[{ns = NotebookSelection[nb], cells, cellObj}, cells = Cells[ns]; Switch[cells, {}, If[Head[cellObj = findNextCellWithGraphics[NextCell[ns]]] === CellObject, selectNextGraphicsInCell[cellObj], None], {_}, If[selectNextGraphicsInCell[First[cells]] === $Failed, selectNextGraphicsInCell[findNextCellWithGraphics[NextCell@First[cells]]]], {__}, selectNextGraphicsInCell[findNextCellWithGraphics[First[cells]]]]]; Efficient way to find and select next Cell containing graphic with preprocessing the whole Notebook
I can suggest tagging all "Output" cells containing GraphicsBox[...] with tag "ContainsGraphicsBox", and then use NotebookFind to select them one-by-one:
(* Create a notebook *) nb = CreateWindow[ DocumentNotebook[{CellGroup[{TextCell["Text Group", "Section"], TextCell["Mary had a little lamb.", "Text"], TextCell["Its fleece was white as snow.", "Text"]}], CellGroup[{TextCell["Graphics Group", "Section"], ExpressionCell[ Plot[Exp[-x^2], {x, -3, 3}], "Output"], ExpressionCell[ Plot[x^2, {x, -3, 3}], "Output"], ExpressionCell[ Plot[x^3, {x, -3, 3}], "Output"]}]}]]; (* Tag all "Output" cells containing GraphicsBox[] as "ContainsGraphicsBox" *) Scan[If[Head[FirstPosition[NotebookRead@#, _GraphicsBox]] =!= Missing, CurrentValue[#, CellTags] = {"ContainsGraphicsBox"}] &, Cells[nb, CellStyle -> "Output"]] (* Find the next cell tagged "ContainsGraphicsBox" *) NotebookFind[nb, "ContainsGraphicsBox", Next, CellTags]; One can use SetSelectedNotebook[nb]; NotebookLocate["ContainsGraphicsBox"] to select them all at once.
Better approach to selectively delete cells with graphics
Another approach is to add to every "Output" cell containing GraphicsBox a CellDingbat with buttons allowing to delete the cell or discard the buttons:
(* Create a notebook *) nb = CreateWindow[ DocumentNotebook[{CellGroup[{TextCell["Text Group", "Section"], TextCell["Mary had a little lamb.", "Text"], TextCell["Its fleece was white as snow.", "Text"]}], CellGroup[{TextCell["Graphics Group", "Section"], ExpressionCell[ Plot[Exp[-x^2], {x, -3, 3}], "Output"], ExpressionCell[ Plot[x^2, {x, -3, 3}], "Output"], ExpressionCell[ Plot[x^3, {x, -3, 3}], "Output"]}]}]]; (* Add to every "Output" cell containing GraphicsBox a CellDingbat with buttons allowing to delete the cell or discard the buttons*) Scan[If[Head[FirstPosition[NotebookRead@#, _GraphicsBox]] =!= Missing, CurrentValue[#, CellDingbat] = Cell[BoxData[ ToBoxes@Column[{Button[Text["Delete Cell", Background -> Red], NotebookDelete[EvaluationCell[]], Appearance -> None], Button[Text["Discard this", Background -> Green], SelectionMove[EvaluationCell[], All, Cell]; CurrentValue[SelectedCells[], CellDingbat] = Inherited, Appearance -> None]}, Left, 0]]]] &, Cells[nb, CellStyle -> "Output"]] Here is a video demonstrating how it works:
We also can combine both approaches, and add functionality to go to the next cell with graphics after pressing the delete or discard button for the current cell:
(* Create a notebook *) nb = CreateWindow[ DocumentNotebook[{CellGroup[{TextCell["Text Group", "Section"], TextCell["Mary had a little lamb.", "Text"], TextCell["Its fleece was white as snow.", "Text"]}], CellGroup[{TextCell["Graphics Group", "Section"], TextCell["Plot 1", "Text"], ExpressionCell[Plot[Exp[-x^2], {x, -3, 3}], "Output"], TextCell["Plot 2", "Text"], ExpressionCell[Plot[x^2, {x, -3, 3}], "Output"], TextCell["Plot 3", "Text"], ExpressionCell[Plot[x^3, {x, -3, 3}], "Output"]}]}]]; (* Add to every "Output" cell containing GraphicsBox a CellDingbat with buttons allowing to delete the cell or discard the buttons *) Scan[If[Head[FirstPosition[NotebookRead@#, _GraphicsBox]] =!= Missing, CurrentValue[#, CellTags] = {"ContainsGraphicsBox"}; CurrentValue[#, CellDingbat] = Cell[BoxData[ ToBoxes@Column[{Button[Text["Delete Cell\n& go next", Background -> Red], SelectionMove[EvaluationCell[], All, Cell]; SelectionMove[EvaluationNotebook[], All, Cell]; With[{sc = SelectedCells[]}, SelectionMove[EvaluationNotebook[], Before, Cell]; NotebookDelete[sc]; NotebookFind[EvaluationNotebook[], "ContainsGraphicsBox", Next, CellTags];], Appearance -> None], Button[Text["Discard this\n& go next", Background -> Green], SelectionMove[EvaluationCell[], All, Cell]; CurrentValue[SelectedCells[], CellDingbat] = Inherited; SelectionMove[EvaluationNotebook[], After, Cell]; NotebookFind[EvaluationNotebook[], "ContainsGraphicsBox", Next, CellTags];, Appearance -> None]}, Left, 0]]]] &, Cells[nb, CellStyle -> "Output"]] This plays well with Mathematica's Undo/Redo functionality.
