Is there a better way to repeatedly add elements to a Graphics(Box)?

Question

Consider simple example where a set of points is generated and some are displayed.

k = 10^5;
p = RandomReal[{-1, 1}, {k, 2}];
n = 2
Graphics[Dynamic@Point@p[[;; n]], Frame -> True, PlotRange -> 1]

Let's plot more and more points from the set:

Dynamic@n
While[n += 100; FinishDynamic[]; n < k - 100]

I find the loop will start to slow down as n gets near to 10^5. This should be expected because the code is replotting all the points at each update of the graphics. (Depending on your system, the rate of slowdown my vary.)

But each time only 100 points are added while the rest of the displayed image remains the same. Naive thinking tells me that there must be a way to do this better.

I have tried many things but with no avail; still, I have a feeling I'm missing something basic.

Answer 1

In your example the resolution of image is going to zero with number of points and you will see the scattered field after addition of some dozens of thousands of points.. What is the sense of such drawing and moreover the sense of dynamic updates of such graphics?

May be it is better to use something like this, with pre-defined size:

data = Table[0, {i, 1000}, {j, 1, 1000}];
Dynamic@Image[data, "Byte"]
k = 10^5;
n = 2;
Dynamic@n
While[n < k - 100,
 n += 100;
 p = RandomInteger[{1, 1000}, {1, 2}];
 data[[
    p[[1, 1]], p[[1, 2]]
    ]] = 255
 ]

It works much faster and each added point is resolvable. You can set really big sizes of image - with 1000x1000 it works in a wink. If you need frameticks, then you can make image Framed and dynamically re-draw it..

---

Kuba's edit...

data = ConstantArray[255, {300, 300}];
Dynamic@Image[data, "Byte"]

Using the code below we can see that performance is the same through the whole process:

i = 0;
Dynamic@i
Do[
   i++;
   p = RandomInteger[{1, 300}, {90, 2}];
   Scan[(data[[#[[1]], #[[2]]]] = 0) &, p];
   FinishDynamic[];
, {1000}]

Kuba:

It's not an answer for the general question about dynamic but it performs extremely well the special case that was shown by me in the question.

Moreover if one removes FinishDynamic[] it will be even faster but not each step is being shown.

At the end I want to remind that the point is not to do that extremely fast but to not lose speed at each iteration like in the question. This code does this so +1 for Rom38 :)

Answer 2

I feel it should be emphasised this answer is quite unpractical and probably a mess.

Note that the FrontEnd displays boxes. So to tell the FrontEnd to draw a Graphics[{Disk[]}] is less direct than to tell it to draw a GraphicsBox[DiskBox[{0, 0}]]. Furthermore, it may be the case that if a box is not changed, it will not have to be redrawn. Even unchanged elements of a GraphicsBox may not have to be redrawn, but loaded from a cache instead. Lastly, it is probably more efficient to render a RasterBox (Image) than other boxes. Despite all this, the code I present here is quite slow, but keep in mind that I draw proper Disks and only one at a time.

Anyway, what the code does is overlay a dynamically generated graphic over another dynamic graphic, which is a raster. The idea is that we periodically put all points/disks into a rasterized graphic and display new points on top of that raster. I have used MousePosition[], as the setting I was thinking of was games, like the game by Michael Hale. In case you want to use MousePosition[], it is not possible to use something like ListAnimate, as you want to generate new graphics on the fly (and also you don't care about old graphics).

Initialisations

kk = 20;
size = 360;
diskSize = 2;

Unevaluated[  
  setGBBAndGB :=
   ({graphicsBuffer, graphicsBufferBoxes} = 
     Transpose[{Disk[#, diskSize], DiskBox[#, diskSize]} & /@ 
       RandomReal[{diskSize, size - diskSize}, {kk, 2}]]);
  ] /. Join[OwnValues[diskSize], OwnValues[size], OwnValues[kk]]

expandRaster := (raster = 
   Rasterize[Graphics[{First@raster, Black, graphicsBuffer}, 
     PlotRange -> {{0, size}, {0, size}}], 
    RasterSize -> {rasterSize, rasterSize}])

jj = 1;
ii = 1;
setGBBAndGB; ;
yMax = 880;
offset = 20;
delay = 2;
rasterSize = 360;

raster = Rasterize[
    Graphics[{White, Rectangle[{0, 0}, {size, size}]}], 
    RasterSize -> {rasterSize, rasterSize}]; ;

Boxes

With[{Yellow = Yellow, 
   rasterBoxes = rasterPrimitiveToBoxes@First@raster, Red = Red, 
   tenK = 10*kk, size = size, delay = delay, quot = quot},
  Cell[

   BoxData@
    GraphicsBox[{
      DynamicBox[
       ToBoxes@raster // First
       ]
      ,
      DynamicBox[
       graphicsBufferBoxes[[;; ii]]
       ]
      ,

      Yellow
      ,

      DynamicBox[
       If[jj == 0,
        If[
         ii == kk - 1
         ,
         expandRaster;
         setGBBAndGB
         ];
        ii = Mod[ii + 1, kk]
        ];
       jj = Mod[jj + 1, delay];



       RectangleBox @@ (Function[
           Function[{#, # + offset}]@{#1/4, (yMax - #2)/3}] @@ 
          MousePosition[])
       ]

      }
     ,
     PlotRange -> {{0, size}, {0, size}}
     ]
   ,
   "Input"
   ]
  ] // CellPrint

Where the code comes from

I evaluated expressions like this

GraphicsRow[{img, Graphics[{Yellow, Disk[{0, 0}, 1]}]}, 
 Spacings -> Scaled[-1.5]]

and fiddled around with the "cell expression" of the result, or the result of calling ToBoxes on this kind of expression.

More about the code

You can see that the rasterisation takes a significant portion of the time, as "Dynamic" lags when rasterisation is being done. You can make everything more smooth by increasing delay.

An improvement would be to use a separate kernel to do the rasterisation. Another improvement might be to rasterise to an image and use an OverlayBox, rather than putting everything into one GraphicsBox.

Answer 3

This is not production ready yet but I won't have time to focus on that soon. Maybe someone else can polish this.

The idea

1. set selection after desired graphics primitive (tricky)
2. NotebookWrite graphics primitives boxes

To manage selection I will use BoxId as in How to set focus of a dialog window?.

Graphics[{ RawBoxes @ PointBox[{0, 0}, "BoxID" -> "test"]}, 
  PlotRange -> 1, 
  ImageSize -> 800, 
  Frame -> True, 
  BaseStyle -> {Red, AbsolutePointSize[1]}
]

Performance test

And now let's start writting:

MathLink`CallFrontEnd[
 FrontEnd`BoxReferenceFind[
  FE`BoxReference[EvaluationNotebook[], {{"test"}}, 
   FE`SearchStart -> "StartFromBeginning"]]
];

SelectionMove[EvaluationNotebook[], After, Box];

tm = First @ Last @ Reap @ Do[
  t = AbsoluteTime[];
  FinishDynamic[];
  NotebookWrite[
    EvaluationNotebook[], PointBox[#]
  ] & @ RandomReal[{-1, 1}, {2000, 2}];
  Sow[{i 2000, AbsoluteTime[] - t}]
  ,
  {i, 100}
]

Initial Dynamic based approach performance test:

x = RandomReal[{-1, 1}, {200001, 2}];
n = 1;
Graphics[Point @ Dynamic @ x[[;; n]], 
  PlotRange -> 1, 
  Frame -> True, 
  BaseStyle -> {Red, AbsolutePointSize[1]}, 
  ImageSize -> 800
]

tm2 = First @ Last @ Reap @ Do[
  t = AbsoluteTime[];
  FinishDynamic[];
  n += 2000;
  Sow[{n , AbsoluteTime[] - t}]
  ,
  {100}
];

Comparison

ListLinePlot[{tm, tm2}, 
  Frame -> True, Axes -> False, 
  FrameLabel -> {"points already in plot", "time spent adding 2000 points"}, 
  BaseStyle -> 18, 
  ImageSize -> 500, 
  PlotLegends -> {"NotebookWrite/PointBox", "Point@Dynamic@x"}
]

So yes, it is way better but unfortunately there is no stable/general way to do this.