Here's another approach (it's bit complicated but faster..) :
(* divide polygon pts to clean up artificials when polygon has holes *)
FindContourBreaks[pts_List] :=
Module[{i, lines, breaks = {}},
lines = {pts[[#[[1]]]], pts[[#[[2]]]]} & /@
Partition[RotateLeft[Flatten[{#, #} & /@ Range[Length[pts]], 1]],
2];
Position[lines,
Alternatives @@
Intersection[{lines[[All, 2]], lines[[All, 1]]} // Transpose,
lines]] // Flatten
];
FindContourBreak[pts_List] :=
Module[{breaks, ranges}, breaks = FindContourBreaks[pts];
ranges =
Partition[
RotateLeft[Join[{1, 1}, Flatten[{#, # + 1} & /@ breaks]]], 2];
ranges = Drop[ranges, -1];
DeleteCases[Range @@@ ranges, x_ /; Length[x] < 3]];
(*generate side polygons - heights *)
SideComplex[pts_List, length_] :=
Module[{topPts, botPts, sideRects, sidePts, sideNormals},
topPts = pts;
botPts = (2 length + 1 - #) & /@ topPts;
sideRects =
Partition[
RotateLeft[Flatten[{#, #} & /@ Range[Length[topPts]], 1]], 2];
sidePts = {topPts[[#[[1]]]], botPts[[#[[1]]]], botPts[[#[[2]]]],
topPts[[#[[2]]]]} & /@ sideRects;
Polygon@sidePts];
(* main code - it create top, bottom, and side polygons *)
To3DComplex[Polygon[list_], depth_: 10] := To3DComplex[list, depth]
To3DComplex[list_List, depth_: 10] /; (Depth[list] == 3) :=
Module[{topPts, botPts, length, contours, sidePolys},
topPts = {#[[1]], #[[2]], depth} & /@ list;
botPts = Reverse[{#[[1]], #[[2]], 0} & /@ topPts];
length = Length[list];
contours = FindContourBreak[list];
sidePolys = SideComplex[#, length] & /@ contours;
GraphicsComplex[
Join[topPts, botPts], {Polygon[Range[length]],
Polygon[Range[length + 1, 2 length] // Reverse], EdgeForm[],
sidePolys}]
]
To3DComplex[list_List, depth_: 10] := To3DComplex[#, depth] & /@ list
Here's example:
divisions =
EntityValue[Entity["AdministrativeDivision", {_, "UnitedStates"}],
"Entities"];
project geoposition to mercator :
dat = (EntityValue[divisions, {"Population", "Polygon"}] /.
GeoPosition[x_] :>
GeoGridPosition[GeoPosition[x], "Mercator"]) /.
GeoGridPosition[x_, "Mercator"] :> x /. Quantity[x_, _] :> x;
rescale population for color function and depth:
pop = Rescale[(# - Min[#]) &@Log[dat[[All, 1]]] // N];
final result (I multiply 20 for depth):
poly = {ColorData["Rainbow"][#1], To3DComplex[#2, 20 #1]} & @@@
Transpose[{pop, dat[[All, 2]]}];
Graphics3D[poly, PlotRange -> {{-60, -130}, {23, 60}, All},
ImageSize -> 800, Boxed -> False]