Hosted pages
interactive map
+289
-2
+289
-2
index.html
+289
-2
index.html
···
9
9
<title>OCaml notebook</title></head>
10
10
<body>
11
11
<h1>OxCaml Notebook</h1>
12
-
<x-ocaml>
13
-
let _ = Printf.printf "Hello, world\n%!";;
12
+
13
+
<x-ocaml mode="interactive">#require "tessera-zarr-jsoo";;
14
+
#require "tessera-viz-jsoo";;
15
+
#require "tessera-tfjs";;
16
+
#require "js_top_worker-widget-leaflet";;
17
+
open Widget_leaflet;;
18
+
register ();;
19
+
(* Load fzstd (Zstd decompressor) and TensorFlow.js *)
20
+
let () =
21
+
let open Js_of_ocaml in
22
+
let import url : unit = Js.Unsafe.fun_call
23
+
(Js.Unsafe.get Js.Unsafe.global (Js.string "importScripts"))
24
+
[| Js.Unsafe.inject (Js.string url) |] in
25
+
import "https://cdn.jsdelivr.net/npm/fzstd@0.1.1/umd/index.js";
26
+
import "https://cdn.jsdelivr.net/npm/@tensorflow/tfjs@4/dist/tf.min.js"</x-ocaml><h2 id="reactive-pipeline"><a href="#reactive-pipeline" class="anchor"></a>Reactive pipeline</h2><p>The entire notebook is a single reactive pipeline. Drawing a bounding box on the map triggers: fetch embeddings → PCA → overlay. Clicking on the map adds training points. The classify button runs kNN and updates the overlay.</p><x-ocaml mode="interactive">let class_colors = [| "#2196F3"; "#4CAF50"; "#FF9800"; "#9C27B0"; "#F44336";
27
+
"#00BCD4"; "#795548"; "#607D8B" |]
28
+
29
+
(* --- Status display --- *)
30
+
31
+
let status_view text =
32
+
let open Widget.View in
33
+
Element { tag = "div"; attrs = [Style ("padding", "8px"); Style ("font-family", "monospace")];
34
+
children = [Text text] }
35
+
36
+
let () = Widget.display ~id:"status" ~handlers:[] (status_view "Draw a rectangle on the map.")
37
+
38
+
(* --- FRP signals --- *)
39
+
40
+
let bbox_signal, set_bbox =
41
+
Note.S.create ~eq:(fun a b -> a = b) (None : Geotessera.bbox option)
42
+
43
+
let year_signal, set_year = Note.S.create ~eq:Int.equal 2024
44
+
45
+
let current_class_signal, set_current_class = Note.S.create ~eq:Int.equal 0
46
+
let class_names_signal, set_class_names =
47
+
Note.S.create ~eq:(fun a b -> a = b) [| "water"; "land" |]
48
+
let training_points_signal, set_training_points =
49
+
Note.S.create ~eq:(fun _ _ -> false) ([] : (float * float * int) list)
50
+
51
+
(* --- Map widget (typed interface) --- *)
52
+
53
+
let () = Widget.display ~id:"debug" ~handlers:[] (status_view "No bbox drawn yet.")
54
+
55
+
let map_ref : Leaflet_map.t option ref = ref None
56
+
let map_get () = match !map_ref with Some m -> m | None -> failwith "map not ready"
57
+
58
+
let map = Leaflet_map.create
59
+
~center:(52.2, 0.12) ~zoom:13 ~height:"500px"
60
+
~on_move:(fun info ->
61
+
Widget.update ~id:"status"
62
+
(status_view (Printf.sprintf "Center: %.5f, %.5f Zoom: %d Bounds: S%.5f W%.5f N%.5f E%.5f"
63
+
info.center.lat info.center.lng info.zoom
64
+
info.bounds.south info.bounds.west info.bounds.north info.bounds.east)))
65
+
~on_bbox_drawn:(fun b ->
66
+
Widget.update ~id:"debug"
67
+
(status_view (Printf.sprintf "Drawn bbox: S%.5f W%.5f N%.5f E%.5f"
68
+
b.south b.west b.north b.east));
69
+
set_bbox (Some Geotessera.{
70
+
min_lat = b.south; min_lon = b.west;
71
+
max_lat = b.north; max_lon = b.east }))
72
+
~on_click:(fun pt ->
73
+
let cls = Note.S.value current_class_signal in
74
+
let points = Note.S.value training_points_signal in
75
+
set_training_points ((pt.lat, pt.lng, cls) :: points);
76
+
let color = class_colors.(cls mod Array.length class_colors) in
77
+
let names = Note.S.value class_names_signal in
78
+
Leaflet_map.add_marker (map_get ()) pt ~color ~label:names.(cls) ())
79
+
()
80
+
let () = map_ref := Some map
81
+
82
+
let () = Leaflet_map.enable_bbox_draw map
83
+
84
+
(* --- Async pipeline: bbox → fetch → mosaic --- *)
85
+
86
+
type mosaic_data = {
87
+
mat : Linalg.mat;
88
+
h : int;
89
+
w : int;
90
+
bounds : Leaflet_map.bounds;
91
+
}
92
+
93
+
let downsample mat ~h ~w ~max_pixels =
94
+
let n = h * w in
95
+
if n <= max_pixels then (mat, h, w)
96
+
else
97
+
let stride = int_of_float (ceil (sqrt (float_of_int n /. float_of_int max_pixels))) in
98
+
let h' = (h + stride - 1) / stride in
99
+
let w' = (w + stride - 1) / stride in
100
+
let out = Linalg.create_mat ~rows:(h' * w') ~cols:mat.Linalg.cols in
101
+
for i = 0 to h' - 1 do
102
+
for j = 0 to w' - 1 do
103
+
let si = min (i * stride) (h - 1) in
104
+
let sj = min (j * stride) (w - 1) in
105
+
for f = 0 to mat.Linalg.cols - 1 do
106
+
Linalg.mat_set out (i * w' + j) f
107
+
(Linalg.mat_get mat (si * w + sj) f)
108
+
done
109
+
done
110
+
done;
111
+
(out, h', w')
112
+
113
+
let bbox_year_signal =
114
+
Note.S.l2 (fun b y -> Option.map (fun b -> (b, y)) b) bbox_signal year_signal
115
+
116
+
let mosaic_signal : mosaic_data Tessera_zarr_jsoo.Frp_async.state Note.signal =
117
+
Tessera_zarr_jsoo.Frp_async.async_bind bbox_year_signal
118
+
(fun (bbox, year) progress ->
119
+
progress (Printf.sprintf "Opening Zarr v2 store (year %d)..." year);
120
+
let open Lwt.Syntax in
121
+
let* store = Tessera_zarr_jsoo.open_store ~year () in
122
+
let* (mat_full, h_full, w_full, geo_bounds) =
123
+
Tessera_zarr.fetch_region ~progress ~year ~store bbox in
124
+
progress (Printf.sprintf "Fetched %d×%d. Downsampling..." h_full w_full);
125
+
let (mat, h, w) = downsample mat_full ~h:h_full ~w:w_full ~max_pixels:1_000_000 in
126
+
let bounds = Leaflet_map.{
127
+
south = geo_bounds.Geotessera.min_lat;
128
+
north = geo_bounds.Geotessera.max_lat;
129
+
west = geo_bounds.Geotessera.min_lon;
130
+
east = geo_bounds.Geotessera.max_lon;
131
+
} in
132
+
Lwt.return { mat; h; w; bounds })
133
+
134
+
(* PCA: runs when mosaic becomes Ready *)
135
+
let pca_signal : Linalg.mat option Note.signal =
136
+
Note.S.map (function
137
+
| Tessera_zarr_jsoo.Frp_async.Ready m ->
138
+
Some (Tfjs.pca m.mat ~n_components:3)
139
+
| _ -> None
140
+
) mosaic_signal
141
+
142
+
(* Overlay: update map when PCA result changes *)
143
+
let _overlay_logr =
144
+
let logr = Note.Logr.create (
145
+
Note.Logr.app (Note.Logr.const (fun pca_opt ->
146
+
match pca_opt, Note.S.value mosaic_signal with
147
+
| Some proj, Tessera_zarr_jsoo.Frp_async.Ready m ->
148
+
let img = Viz.pca_to_rgba ~width:m.w ~height:m.h proj in
149
+
let url = Viz_jsoo.to_data_url img in
150
+
Leaflet_map.add_image_overlay map ~url ~bounds:m.bounds ~opacity:0.7 ()
151
+
| _ -> ()
152
+
)) (Note.S.obs pca_signal))
153
+
in Note.Logr.hold logr
154
+
155
+
(* Status: update display reactively *)
156
+
let _status_logr =
157
+
let logr = Note.Logr.create (
158
+
Note.Logr.app (Note.Logr.const (fun state ->
159
+
let text = match state with
160
+
| Tessera_zarr_jsoo.Frp_async.Idle ->
161
+
"Draw a rectangle on the map."
162
+
| Loading msg -> Printf.sprintf "Loading: %s" msg
163
+
| Ready m ->
164
+
Printf.sprintf "Ready: %d×%d mosaic. Click to add training points." m.h m.w
165
+
| Error msg -> Printf.sprintf "Error: %s" msg
166
+
in
167
+
Widget.update ~id:"status" (status_view text)
168
+
)) (Note.S.obs mosaic_signal))
169
+
in Note.Logr.hold logr</x-ocaml><h2 id="year-selection"><a href="#year-selection" class="anchor"></a>Year selection</h2><p>Select the year for the GeoTessera embeddings (2017–2025). Changing the year re-fetches the current bounding box.</p><x-ocaml mode="interactive">let make_year_buttons () =
170
+
let open Widget.View in
171
+
let current = Note.S.value year_signal in
172
+
let buttons = List.map (fun y ->
173
+
let border = if y = current then "3px solid black" else "1px solid #ccc" in
174
+
Element { tag = "button";
175
+
attrs = [
176
+
Handler ("click", "year_" ^ string_of_int y);
177
+
Style ("margin", "2px"); Style ("padding", "6px 12px");
178
+
Style ("border", border); Style ("border-radius", "4px");
179
+
Style ("cursor", "pointer");
180
+
];
181
+
children = [Text (string_of_int y)] }
182
+
) [2017; 2018; 2019; 2020; 2021; 2022; 2023; 2024; 2025] in
183
+
Element { tag = "div";
184
+
attrs = [Style ("padding", "8px")];
185
+
children = Element { tag = "b"; attrs = []; children = [Text "Year: "] } :: buttons }
186
+
187
+
let () =
188
+
let handlers = List.map (fun y ->
189
+
"year_" ^ string_of_int y, (fun (_v : string option) ->
190
+
set_year y;
191
+
Widget.update ~id:"year-buttons" (make_year_buttons ()))
192
+
) [2017; 2018; 2019; 2020; 2021; 2022; 2023; 2024; 2025] in
193
+
Widget.display ~id:"year-buttons" ~handlers (make_year_buttons ())</x-ocaml><h2 id="label-training-points"><a href="#label-training-points" class="anchor"></a>Label training points</h2><p>Click on the map to add training points. Use the buttons below to switch classes, classify, or clear.</p><x-ocaml mode="interactive">let make_class_buttons () =
194
+
let open Widget.View in
195
+
let names = Note.S.value class_names_signal in
196
+
let cls = Note.S.value current_class_signal in
197
+
let buttons = Array.to_list (Array.mapi (fun i name ->
198
+
let color = class_colors.(i mod Array.length class_colors) in
199
+
let border = if i = cls then "3px solid black" else "1px solid #ccc" in
200
+
Element { tag = "button";
201
+
attrs = [
202
+
Handler ("click", "class_" ^ string_of_int i);
203
+
Style ("margin", "4px"); Style ("padding", "8px 16px");
204
+
Style ("background", color); Style ("color", "white");
205
+
Style ("border", border); Style ("border-radius", "4px");
206
+
Style ("cursor", "pointer");
207
+
];
208
+
children = [Text name] }
209
+
) names) in
210
+
Element { tag = "div";
211
+
attrs = [Style ("padding", "8px")];
212
+
children =
213
+
Element { tag = "b"; attrs = []; children = [Text "Active class: "] }
214
+
:: buttons
215
+
@ [Element { tag = "button";
216
+
attrs = [ Handler ("click", "add_class");
217
+
Style ("margin", "4px"); Style ("padding", "8px 16px");
218
+
Style ("border", "1px dashed #999"); Style ("border-radius", "4px");
219
+
Style ("cursor", "pointer") ];
220
+
children = [Text "+ Add class"] };
221
+
Element { tag = "button";
222
+
attrs = [ Handler ("click", "classify");
223
+
Style ("margin", "4px"); Style ("padding", "8px 16px");
224
+
Style ("background", "#FF5722"); Style ("color", "white");
225
+
Style ("border", "none"); Style ("border-radius", "4px");
226
+
Style ("cursor", "pointer"); Style ("font-weight", "bold") ];
227
+
children = [Text "Classify"] };
228
+
Element { tag = "button";
229
+
attrs = [ Handler ("click", "clear_points");
230
+
Style ("margin", "4px"); Style ("padding", "8px 16px");
231
+
Style ("border", "1px solid #ccc"); Style ("border-radius", "4px");
232
+
Style ("cursor", "pointer") ];
233
+
children = [Text "Clear all"] }]
234
+
}
235
+
236
+
let () =
237
+
let names = Note.S.value class_names_signal in
238
+
let handlers =
239
+
Array.to_list (Array.mapi (fun i _name ->
240
+
"class_" ^ string_of_int i, (fun (_v : string option) ->
241
+
set_current_class i;
242
+
Widget.update ~id:"class-buttons" (make_class_buttons ()))
243
+
) names)
244
+
@ [
245
+
"add_class", (fun _v ->
246
+
let names = Note.S.value class_names_signal in
247
+
let n = Array.length names in
248
+
set_class_names (Array.append names [| "class_" ^ string_of_int n |]);
249
+
set_current_class n;
250
+
Widget.update ~id:"class-buttons" (make_class_buttons ()));
251
+
"classify", (fun _v ->
252
+
let points = Note.S.value training_points_signal in
253
+
(match Note.S.value mosaic_signal with
254
+
| Tessera_zarr_jsoo.Frp_async.Ready m when points <> [] ->
255
+
Widget.update ~id:"status"
256
+
(status_view (Printf.sprintf "Classifying with %d points..." (List.length points)));
257
+
let n_train = List.length points in
258
+
let train_mat = Linalg.create_mat ~rows:n_train ~cols:m.mat.Linalg.cols in
259
+
let train_labels = Array.make n_train 0 in
260
+
List.iteri (fun i (lat, lng, cls) ->
261
+
let row = int_of_float ((m.bounds.north -. lat) /.
262
+
(m.bounds.north -. m.bounds.south) *. float_of_int m.h) in
263
+
let col = int_of_float ((lng -. m.bounds.west) /.
264
+
(m.bounds.east -. m.bounds.west) *. float_of_int m.w) in
265
+
let row = max 0 (min (m.h - 1) row) in
266
+
let col = max 0 (min (m.w - 1) col) in
267
+
let src = (row * m.w + col) * m.mat.Linalg.cols in
268
+
let dst = i * m.mat.Linalg.cols in
269
+
for j = 0 to m.mat.Linalg.cols - 1 do
270
+
Bigarray.Array1.set train_mat.Linalg.data (dst + j)
271
+
(Bigarray.Array1.get m.mat.Linalg.data (src + j))
272
+
done;
273
+
train_labels.(i) <- cls
274
+
) points;
275
+
let model = Linalg.knn_fit ~embeddings:train_mat ~labels:train_labels in
276
+
let k = min 5 n_train in
277
+
let result = Linalg.knn_predict model ~k m.mat in
278
+
let n_classes = Array.fold_left max 0 train_labels + 1 in
279
+
let colors = List.init n_classes (fun i ->
280
+
(i, Viz.color_of_hex class_colors.(i mod Array.length class_colors))) in
281
+
let img = Viz.classification_to_rgba
282
+
~predictions:result.Linalg.predictions
283
+
~colors ~width:m.w ~height:m.h () in
284
+
let url = Viz_jsoo.to_data_url img in
285
+
Leaflet_map.add_image_overlay map ~url ~bounds:m.bounds ~opacity:0.7 ();
286
+
Widget.update ~id:"status"
287
+
(status_view (Printf.sprintf "Classification complete! %d classes, %d points."
288
+
n_classes n_train))
289
+
| _ ->
290
+
Widget.update ~id:"status" (status_view "Need mosaic + training points first.")));
291
+
"clear_points", (fun _v ->
292
+
set_training_points [];
293
+
Leaflet_map.clear_markers map;
294
+
Widget.update ~id:"status" (status_view "Cleared all training points."));
295
+
]
296
+
in
297
+
Widget.display ~id:"class-buttons" ~handlers (make_class_buttons ())</x-ocaml></div></main>
298
+
299
+
300
+
14
301
15
302
</body>
16
303
</html>