Hosted pages
cut down
+3
-162
+3
-162
index.html
+3
-162
index.html
···
52
52
53
53
let () = Widget.display ~id:"debug" ~handlers:[] (status_view "No bbox drawn yet.")
54
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
55
let map = Leaflet_map.create
59
56
~center:(52.2, 0.12) ~zoom:13 ~height:"500px"
60
57
~on_move:(fun info ->
···
69
66
set_bbox (Some Geotessera.{
70
67
min_lat = b.south; min_lon = b.west;
71
68
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
69
()
80
-
let () = map_ref := Some map
81
70
82
71
let () = Leaflet_map.enable_bbox_draw map
83
72
···
90
79
bounds : Leaflet_map.bounds;
91
80
}
92
81
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
82
let bbox_year_signal =
114
83
Note.S.l2 (fun b y -> Option.map (fun b -> (b, y)) b) bbox_signal year_signal
115
84
···
119
88
progress (Printf.sprintf "Opening Zarr v2 store (year %d)..." year);
120
89
let open Lwt.Syntax in
121
90
let* store = Tessera_zarr_jsoo.open_store ~year () in
122
-
let* (mat_full, h_full, w_full, geo_bounds) =
91
+
let* (mat, h, w, geo_bounds) =
123
92
Tessera_zarr.fetch_region ~progress ~year ~store bbox in
124
93
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
94
let bounds = Leaflet_map.{
127
95
south = geo_bounds.Geotessera.min_lat;
128
96
north = geo_bounds.Geotessera.max_lat;
···
166
134
in
167
135
Widget.update ~id:"status" (status_view text)
168
136
)) (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>
137
+
in Note.Logr.hold logr</x-ocaml>
138
+
</div></main>
298
139
299
140
300
141