Slow rendering in GraphPlot3D

Question

Is there a way to speed up this rendering? I have to make this call many times in order to make an animation of some dynamics on the graph g. Thus dynamics are carried in the list var. Each entry in var has the 25,000 values of a function that is defined on the nodes of g. The first entry gives those 25,000 values at the first time point, the second gives them at the second time point, etc. The only thing changing is the coloring of the graph but not the graph itself. The graphs I am looking at look like knotted snarls. The parameters (sphere radius, ImageSize, maxvar, etc) are fixed.

GraphPlot3D[g, VertexRenderingFunction -> ({ColorData["TemperatureMap"][
  Rescale[var[[t]], {0, maxvar}][[#2]]], 
  Sphere[#1, 2.5]} &), ImageSize -> 1000, 
  PreserveImageOptions -> True]

It looks like it will take some 15 hours to do the rendering for a simulation that took a few minutes. Is there some way to take advantage of the fact that g is fixed? Or is there some other approach entirely that would give the same output in less time? I'd like to be able to do about 1-2000 frames of this. Each frame takes over a minute.

Most of the values contained in var don't change much from time point to time point either. var takes on only integer values. Perhaps there is something I could do by computing dvar = var[[t]]-var[[t-1]] . dvar would be zero over most of the graph.

Another thing that might save a little time is that I don't need to render most of the edges as they can't be seen anyway. There are about 30 edges that I would want to render. I have no idea how to render a subset of the edges. I don't know if it would save much time but I guess I can check that by setting EdgeRenderingFunction->None ?

Here is the sample code requested by bbgodfrey.

g = Graph[{1 <-> 2, 2 <-> 3, 3 <-> 4, 4 <-> 5, 5 <-> 6, 6 <-> 7, 
7 <-> 8, 8 <-> 9, 9 <-> 10, 1 <-> 10, 4 <-> 10}]
var = {{}, {}};
var[[1]] = ConstantArray[0, 10];
var[[1, 6 ;;]] = RandomInteger[{8, 10}, 5];
dvar = ConstantArray[0, 10];
dvar[[4 ;; 5]] = 10;
var[[2]] = var[[1]] + dvar;
var[[1]]
var[[2]]
maxvar = Max[var];
GraphPlot3D[g, 
   VertexRenderingFunction -> ({ColorData["TemperatureMap"][
   Rescale[var[[1]], {0, maxvar}][[#2]]], Sphere[#1, 2.5]} &), 
   ImageSize -> 1000, PreserveImageOptions -> True] // Timing
GraphPlot3D[g, 
   VertexRenderingFunction -> ({ColorData["TemperatureMap"][
   Rescale[var[[2]], {0, maxvar}][[#2]]], Sphere[#1, 2.5]} &), 
   ImageSize -> 1000, PreserveImageOptions -> True] // Timing

Answer 1

I suggest you try the following. Set your two plots in the Question to p1 and p2. Then,

col = Map[ColorData["TemperatureMap"][#] &, Rescale[var[[2]], {0, maxvar}]];
ans = MapIndexed[(#1 /. (RGBColor[__] -> col[[Last[#2]]])) &, p1 // InputForm, {6}]; ans[[1]]

reproduces p2 without calling GraphPlot3D, which should be faster. This process can, of course, be used for each subsequent plot. Please let me know, if it actually is significantly faster. (Warning: I have not tested this in detail, and it may not give correct results in all cases. If it provides a significant time improvement, we can chase any bugs.)

Answer 2

Since you are only drawing Spheres (like @belisarius mentioned), GraphEmbedding and Graphics3D will be enough to do this (GraphicsComplex may not help that much in this situation).

For example,

g = RandomGraph[{100, 150}];
coord = GraphEmbedding[g, Automatic, 3];
colors = ColorData["TemperatureMap"] /@ RandomReal[{0, 1}, 100];;

spheres = MapThread[{#, Sphere[#2, 2.5]} &, {colors, coord}];

Graphics3D[spheres, ImageSize -> 1000, PreserveImageOptions -> True]

If you also draw some edges:

Using Graph3D:

subedges = {1 <-> 2, 2 <-> 3, 3 <-> 4};
edges = {None, Thread[subedges -> "Line"]};

Graph3D[g, VertexShapeFunction -> (Sphere[#, 2.5] &), 
 VertexStyle -> Thread[VertexList[g] -> colors], 
 EdgeShapeFunction -> edges, VertexCoordinates -> coord, 
 ImageSize -> 1000, PreserveImageOptions -> True]

Graphics3D:

ispheres = MapIndexed[{#, Sphere[#2[[1]], 2.5]} &, colors];
Graphics3D[
 GraphicsComplex[coord, {ispheres, Line[Tube @@@ subedges]}], 
 ImageSize -> 1000, PreserveImageOptions -> True]