forked from
anil.recoil.org/monopam-myspace
My aggregated monorepo of OCaml code, automaintained
Update original notebook to use typed Leaflet_map wrapper
Both notebooks now use Leaflet_map instead of raw Widget.command/Scanf.
No more string command names, no more manual JSON serialization/parsing
for map interactions.
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
+51
-90
+51
-90
site/notebooks/interactive_map.mld
+51
-90
site/notebooks/interactive_map.mld
···
36
36
(* Shared state *)
37
37
let bbox : Geotessera.bbox option ref = ref None
38
38
let mosaic : (Linalg.mat * int * int) option ref = ref None
39
-
let mosaic_bounds : Geotessera.bbox option ref = ref None
39
+
let mosaic_bounds : Leaflet_map.bounds option ref = ref None
40
40
let projected : Linalg.mat option ref = ref None
41
41
let training_points : (float * float * int) list ref = ref []
42
42
let current_class = ref 0
···
66
66
done;
67
67
(out, h', w')
68
68
69
-
let map_id = "tessera-map"
70
-
71
69
let status_view text =
72
70
let open Widget.View in
73
71
Element { tag = "div"; attrs = [Style ("padding", "8px"); Style ("font-family", "monospace")];
···
75
73
76
74
let () = Widget.display ~id:"status" ~handlers:[] (status_view "Draw a rectangle on the map.")
77
75
78
-
let () =
79
-
Widget.display_managed ~id:map_id
80
-
~kind:"leaflet-map"
81
-
~config:{| {"center": [52.2, 0.12], "zoom": 13, "height": "500px"} |}
82
-
~handlers:[
83
-
"bbox_drawn", (fun v ->
84
-
match v with
85
-
| Some json ->
86
-
(* Parse bbox JSON: {"south":..,"west":..,"north":..,"east":..} *)
87
-
let s = Scanf.sscanf json
88
-
{| {"south":%f,"west":%f,"north":%f,"east":%f}|}
89
-
(fun s w n e -> Geotessera.{ min_lat = s; min_lon = w; max_lat = n; max_lon = e })
90
-
in
91
-
bbox := Some s;
92
-
Widget.update ~id:"status"
93
-
(status_view (Printf.sprintf "Selected: %.4f,%.4f to %.4f,%.4f — run next cell to fetch embeddings."
94
-
s.min_lat s.min_lon s.max_lat s.max_lon))
95
-
| None -> ());
96
-
"click", (fun v ->
97
-
match v with
98
-
| Some json ->
99
-
let lat, lng = Scanf.sscanf json {| {"lat":%f,"lng":%f}|} (fun a b -> (a, b)) in
100
-
(match !mosaic with
101
-
| None -> () (* ignore clicks before embeddings loaded *)
102
-
| Some _ ->
103
-
let cls = !current_class in
104
-
training_points := (lat, lng, cls) :: !training_points;
105
-
let color = class_colors.(cls mod Array.length class_colors) in
106
-
let label = (!class_names).(cls) in
107
-
Widget.command ~id:map_id "addMarker"
108
-
(Printf.sprintf {|{"lat":%f,"lng":%f,"color":"%s","label":"%s"}|}
109
-
lat lng color label);
110
-
Widget.update ~id:"status"
111
-
(status_view (Printf.sprintf "Added %s point at %.4f, %.4f (%d points total)"
112
-
label lat lng (List.length !training_points))))
113
-
| None -> ());
114
-
]
76
+
let map = Leaflet_map.create
77
+
~center:(52.2, 0.12) ~zoom:13 ~height:"500px"
78
+
~on_bbox_drawn:(fun b ->
79
+
bbox := Some Geotessera.{
80
+
min_lat = b.south; min_lon = b.west;
81
+
max_lat = b.north; max_lon = b.east };
82
+
Widget.update ~id:"status"
83
+
(status_view (Printf.sprintf "Selected: %.4f,%.4f to %.4f,%.4f — run next cell to fetch embeddings."
84
+
b.south b.west b.north b.east)))
85
+
~on_click:(fun pt ->
86
+
match !mosaic with
87
+
| None -> ()
88
+
| Some _ ->
89
+
let cls = !current_class in
90
+
training_points := (pt.lat, pt.lng, cls) :: !training_points;
91
+
let color = class_colors.(cls mod Array.length class_colors) in
92
+
let label = (!class_names).(cls) in
93
+
Leaflet_map.add_marker map pt ~color ~label ();
94
+
Widget.update ~id:"status"
95
+
(status_view (Printf.sprintf "Added %s point at %.4f, %.4f (%d points total)"
96
+
label pt.lat pt.lng (List.length !training_points))))
97
+
()
115
98
116
-
let () = Widget.command ~id:map_id "enableBboxDraw" ""
99
+
let () = Leaflet_map.enable_bbox_draw map
117
100
]}
118
101
119
102
{1 Fetch embeddings and visualise}
···
127
110
| None -> Widget.update ~id:"status" (status_view "Error: draw a bounding box first!")
128
111
| Some b ->
129
112
Widget.update ~id:"status" (status_view "Fetching embeddings...");
130
-
let mat_full, h_full, w_full, mosaic_bbox = Geotessera_jsoo.fetch_mosaic ~year:2024 b in
113
+
let mat_full, h_full, w_full, geo_bbox = Geotessera_jsoo.fetch_mosaic ~year:2024 b in
131
114
Widget.update ~id:"status"
132
115
(status_view (Printf.sprintf "Fetched %d×%d mosaic. Downsampling..." h_full w_full));
133
116
let mat, h, w = downsample_mosaic mat_full ~h:h_full ~w:w_full ~max_pixels:50_000 in
134
117
mosaic := Some (mat, h, w);
135
-
mosaic_bounds := Some mosaic_bbox;
136
-
(* Use actual WGS84 bounds computed from UTM tile geometry *)
137
-
let mosaic_south = mosaic_bbox.Geotessera.min_lat in
138
-
let mosaic_north = mosaic_bbox.Geotessera.max_lat in
139
-
let mosaic_west = mosaic_bbox.Geotessera.min_lon in
140
-
let mosaic_east = mosaic_bbox.Geotessera.max_lon in
118
+
let bounds = Leaflet_map.{
119
+
south = geo_bbox.Geotessera.min_lat;
120
+
north = geo_bbox.Geotessera.max_lat;
121
+
west = geo_bbox.Geotessera.min_lon;
122
+
east = geo_bbox.Geotessera.max_lon;
123
+
} in
124
+
mosaic_bounds := Some bounds;
141
125
Widget.update ~id:"status"
142
126
(status_view (Printf.sprintf "Working at %d×%d (%d pixels). Computing PCA..." h w (h * w)));
143
127
(* PCA to 3 components for RGB visualisation (via TensorFlow.js SVD) *)
···
145
129
projected := Some proj;
146
130
let pca_img = Viz.pca_to_rgba ~width:w ~height:h proj in
147
131
let url = Viz_jsoo.to_data_url pca_img in
148
-
Widget.command ~id:map_id "addImageOverlay"
149
-
(Printf.sprintf {|{"url":"%s","bounds":[[%f,%f],[%f,%f]],"opacity":0.7}|}
150
-
url mosaic_south mosaic_west mosaic_north mosaic_east);
132
+
Leaflet_map.add_image_overlay map ~url ~bounds ~opacity:0.7 ();
151
133
Widget.update ~id:"status"
152
134
(status_view "PCA overlay added. Click on the map to place training points, then run the classification cell.")
153
135
]}
···
166
148
Element { tag = "button";
167
149
attrs = [
168
150
Handler ("click", "class_" ^ string_of_int i);
169
-
Style ("margin", "4px");
170
-
Style ("padding", "8px 16px");
171
-
Style ("background", color);
172
-
Style ("color", "white");
173
-
Style ("border", border);
174
-
Style ("border-radius", "4px");
151
+
Style ("margin", "4px"); Style ("padding", "8px 16px");
152
+
Style ("background", color); Style ("color", "white");
153
+
Style ("border", border); Style ("border-radius", "4px");
175
154
Style ("cursor", "pointer");
176
155
];
177
156
children = [Text name] }
···
182
161
Element { tag = "b"; attrs = []; children = [Text "Active class: "] }
183
162
:: buttons
184
163
@ [Element { tag = "button";
185
-
attrs = [
186
-
Handler ("click", "add_class");
187
-
Style ("margin", "4px");
188
-
Style ("padding", "8px 16px");
189
-
Style ("border", "1px dashed #999");
190
-
Style ("border-radius", "4px");
191
-
Style ("cursor", "pointer");
192
-
];
164
+
attrs = [ Handler ("click", "add_class");
165
+
Style ("margin", "4px"); Style ("padding", "8px 16px");
166
+
Style ("border", "1px dashed #999"); Style ("border-radius", "4px");
167
+
Style ("cursor", "pointer") ];
193
168
children = [Text "+ Add class"] };
194
169
Element { tag = "button";
195
-
attrs = [
196
-
Handler ("click", "clear_points");
197
-
Style ("margin", "4px");
198
-
Style ("padding", "8px 16px");
199
-
Style ("border", "1px solid #ccc");
200
-
Style ("border-radius", "4px");
201
-
Style ("cursor", "pointer");
202
-
];
170
+
attrs = [ Handler ("click", "clear_points");
171
+
Style ("margin", "4px"); Style ("padding", "8px 16px");
172
+
Style ("border", "1px solid #ccc"); Style ("border-radius", "4px");
173
+
Style ("cursor", "pointer") ];
203
174
children = [Text "Clear all"] }]
204
175
}
205
176
···
218
189
Widget.update ~id:"class-buttons" (make_class_buttons ()));
219
190
"clear_points", (fun _v ->
220
191
training_points := [];
221
-
Widget.command ~id:map_id "clearMarkers" "";
192
+
Leaflet_map.clear_markers map;
222
193
Widget.update ~id:"status" (status_view "Cleared all training points."));
223
194
]
224
195
···
236
207
{@ocaml x[
237
208
let () =
238
209
match !mosaic, !projected, !mosaic_bounds with
239
-
| Some (mat, h, w), Some _proj, Some mb ->
210
+
| Some (mat, h, w), Some _proj, Some bounds ->
240
211
let points = !training_points in
241
212
if points = [] then
242
213
Widget.update ~id:"status" (status_view "Error: place some training points first!")
243
214
else begin
244
215
Widget.update ~id:"status"
245
216
(status_view (Printf.sprintf "Classifying with %d training points..." (List.length points)));
246
-
(* Use stored mosaic bounds computed from UTM tile geometry *)
247
-
let mosaic_south = mb.Geotessera.min_lat in
248
-
let mosaic_north = mb.Geotessera.max_lat in
249
-
let mosaic_west = mb.Geotessera.min_lon in
250
-
let mosaic_east = mb.Geotessera.max_lon in
251
-
(* Convert geo coords to pixel coords and extract embeddings *)
252
217
let n_train = List.length points in
253
218
let train_mat = Linalg.create_mat ~rows:n_train ~cols:mat.Linalg.cols in
254
219
let train_labels = Array.make n_train 0 in
255
220
List.iteri (fun i (lat, lng, cls) ->
256
-
(* Map lat/lng to pixel row/col using mosaic bounds *)
257
-
let row = int_of_float ((mosaic_north -. lat) /. (mosaic_north -. mosaic_south) *. float_of_int h) in
258
-
let col = int_of_float ((lng -. mosaic_west) /. (mosaic_east -. mosaic_west) *. float_of_int w) in
221
+
let row = int_of_float ((bounds.north -. lat) /.
222
+
(bounds.north -. bounds.south) *. float_of_int h) in
223
+
let col = int_of_float ((lng -. bounds.west) /.
224
+
(bounds.east -. bounds.west) *. float_of_int w) in
259
225
let row = max 0 (min (h - 1) row) in
260
226
let col = max 0 (min (w - 1) col) in
261
-
(* Copy embedding row *)
262
227
let src_offset = (row * w + col) * mat.Linalg.cols in
263
228
let dst_offset = i * mat.Linalg.cols in
264
229
for j = 0 to mat.Linalg.cols - 1 do
···
267
232
done;
268
233
train_labels.(i) <- cls
269
234
) points;
270
-
(* kNN classification *)
271
235
let model = Linalg.knn_fit ~embeddings:train_mat ~labels:train_labels in
272
236
let k = min 5 n_train in
273
237
let result = Linalg.knn_predict model ~k mat in
274
-
(* Build color map *)
275
238
let n_classes = Array.fold_left max 0 train_labels + 1 in
276
239
let colors = List.init n_classes (fun i ->
277
240
let hex = class_colors.(i mod Array.length class_colors) in
···
281
244
~predictions:result.Linalg.predictions
282
245
~colors ~width:w ~height:h () in
283
246
let class_url = Viz_jsoo.to_data_url class_img in
284
-
Widget.command ~id:map_id "addImageOverlay"
285
-
(Printf.sprintf {|{"url":"%s","bounds":[[%f,%f],[%f,%f]],"opacity":0.7}|}
286
-
class_url mosaic_south mosaic_west mosaic_north mosaic_east);
247
+
Leaflet_map.add_image_overlay map ~url:class_url ~bounds ~opacity:0.7 ();
287
248
Widget.update ~id:"status"
288
249
(status_view (Printf.sprintf "Classification complete! %d classes, %d training points."
289
250
n_classes n_train))