Identify which cell uses most memory in front-end

Question

Even though the mathematica front-end is much more robust than it used to be, everyone must have noticed that when a few 3D graphics are involved, the front-end produces very large notebooks which are more difficult to manage.

I am aware of the option to rasterise 3D plots using Image

 Plot3D[Sin[1/x 1/y],{x,0,1},{y,0,1},PlotPoints -> 200]//Image[#,ImageResolution-> 300]&

which produces a file of 1.2 MB versus one of 11 MB (without the Image).

I am looking for a method to identify within a given notebook which graphics outputs use most memory on the front-end (and potentially disc space when the notebook is saved), in order to rasterize these outputs. Ideally I would rather not rasterize all plots as the interactivity is useful.

Note that this question differs from my previous question about identifying which outputs use most kernel memory when stored in Out[] variables.

Question

1. How to identify which cells use most memory on the front-end in a given notebook?
2. Possibly automate the process of rasterising those cells?

May be there is a front end setup to tell it to not produce interactive plots?

Answer 1

@Brett has just posted something along the lines of what I was thinking. I had a look at the code for the cell statistics and it uses CurrentValue so a manual approach would be to evaluate:

Dynamic@CurrentValue[EvaluationNotebook[], "ByteCount"]

and then click on a cell bracket and observe the byte count. This can probably be automated using SelectionMove to step through the cells and record the byte count.

Edit

Using SelectionMove (I added a pause just to watch it working)

x = {};
Do[SelectionMove[nb, Previous, Cell]; 
  x = {x, First@CurrentValue[EvaluationNotebook[], "ByteCount"]}; 
  Pause[0.5], {15}];
Flatten[x]

(* {932, 7258, 992, 1039, 2150, 35190, 2121, 992, 2584, 9408, 1016, \
1791, 1529, 1657, 2775} *)

In principle you can also record the cell label and thereby identify which cell has large byte counts. For some reason this was not working for me and i haven't been able to figure out what the problem is. It works fine in the documentation notebook:

However when I cut and paste the code into a notebook and evaluate it doesn't work:

So if someone can explain why I am failing to obtain a cell label then the Do loop above can be modified to record the cell label and corresponding byte count.

Edit #2

restarted Mma and now this is working, so starting from the bottom of your notebook (selecting 15 cells in this example):

x = {};
nb=EvaluationNotebook[];
Do[SelectionMove[nb, Previous, Cell]; 
  x = {x, {Options[NotebookSelection[nb], CellLabel][[-1, 2]], 
     First@CurrentValue[nb, "ByteCount"]}}; 
  Pause[0.5], {15}];
Partition[Flatten[x], 2]

(* {{"Out[122]=", 14811}, {"In[123]:=", 10149}, {"Out[93]=", 
  3490}, {"In[91]:=", 7127}, {None, 992}, {"Out[90]=", 
  1006}, {"In[90]:=", 2134}, {"Out[89]=", 35008}, {"In[89]:=", 
  2071}, {None, 992}, {"In[87]:=", 2543}, {"Out[86]=", 
  9259}, {"In[86]:=", 1015}, {"In[85]:=", 1785}, {"In[84]:=", 1515}} *)

or for a big notebook limit the output to byte counts above a certain level

Cases[Partition[Flatten[x], 2], {_, x_ /; x > 10000}]
(* {{"Out[122]=", 14811}, {"In[123]:=", 10149}, {"Out[89]=", 35008}} *)

Edit #3

In response to @Chris conversation

nb = EvaluationNotebook[];
Do[
  SelectionMove[nb, Previous, Cell];
  tmp = First@CurrentValue[nb, "ByteCount"];
  If[tmp > 10000, 
   SetOptions[NotebookSelection[nb], CellDingbat -> "Big"]];,
  {15}];

Answer 2

Here's a manual process:

• Bring up the Notebook History... dialog (located in the Cells menu)
• Set the history to Selected Cells
• Open the Cell Statistics section
• Select a cell, and read the value out of the table:

Answer 3

You could use NotebookGet to access the underlying Notebook expression and then process it. Use Notebooks[] to find an open Notebook, or NotebookOpen to open one, and assign the NotebookObject to nb. In a new window:

Notebooks[]
nb = %[[3]];

Then we can print all cells that take over 1MB of storage:

Cases[NotebookGet[nb], 
  x : Cell[__, "Output"] /; ByteCount[x] > 1*^6 :> CellPrint@x, -1];

This doesn't help you locate the cells but it does identify them.

You could also print corresponding Input cells if that makes localization easier:

Cases[NotebookGet[nb], 
 x : CellGroupData[{Cell[__, "Input"], __}, __] /; 
   ByteCount[x] > 1*^6 :> CellPrint@Cell@x, -1]