forked from
anil.recoil.org/monopam-myspace
My aggregated monorepo of OCaml code, automaintained
Rewrite Zarr notebook with FRP reactive pipeline
- Entire notebook is a reactive pipeline: drawing bbox automatically
triggers fetch → PCA → overlay update
- Uses Note signals throughout: bbox_signal, mosaic_signal (async state),
pca_signal, training_points_signal, current_class_signal
- Frp_async.async_bind bridges Note signals to Lwt: Loading/Ready/Error
states with stale request cancellation
- Status bar updates reactively from mosaic_signal state
- PCA overlay updates reactively when pca_signal changes
- Classification triggered by button, samples mosaic + points signals
- No mutable refs — all state in Note signals
- Only 2 cells: the reactive pipeline + the class buttons/classify UI
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
+217
-206
+217
-206
site/notebooks/interactive_map_zarr.mld
+217
-206
site/notebooks/interactive_map_zarr.mld
···
2
2
3
3
Explore geospatial embeddings from the
4
4
{{:https://geotessera.org}GeoTessera} foundation model
5
-
directly in the browser. This version fetches embeddings from
6
-
the GeoTessera {{:https://anil.recoil.org/notes/tessera-zarr-v3-layout}Zarr v3 store},
7
-
loading only the shards needed for your region of interest.
8
-
9
-
{ol
10
-
{- Draw a bounding box to select your region of interest}
11
-
{- Fetch and visualise GeoTessera embeddings with PCA}
12
-
{- Click on the map to place labelled training points}
13
-
{- Run k-nearest-neighbours classification}
14
-
{- View the classification overlay}}
5
+
directly in the browser. This version uses the GeoTessera
6
+
{{:https://anil.recoil.org/notes/tessera-zarr-v3-layout}Zarr v3 store}
7
+
and a reactive (FRP) architecture — drawing a bounding box
8
+
automatically triggers fetching, PCA visualisation, and overlay
9
+
updates.
15
10
16
11
{@ocaml kind=setup[
17
12
#require "tessera-zarr-jsoo";;
···
19
14
#require "tessera-tfjs";;
20
15
#require "js_top_worker-widget-leaflet";;
21
16
Widget_leaflet.register ();;
22
-
(* Load TensorFlow.js in the worker *)
17
+
(* Load TensorFlow.js *)
23
18
let () =
24
19
let open Js_of_ocaml in
25
20
Js.Unsafe.fun_call
···
27
22
[| Js.Unsafe.inject (Js.string "https://cdn.jsdelivr.net/npm/@tensorflow/tfjs@4/dist/tf.min.js") |]
28
23
]}
29
24
30
-
{1 Select region of interest}
25
+
{1 Reactive pipeline}
31
26
32
-
Draw a rectangle on the map to select the area you want to classify.
33
-
The map is centred on Cambridge, UK — navigate to any area of interest
34
-
before drawing.
27
+
The entire notebook is a single reactive pipeline. Drawing a bounding
28
+
box on the map triggers: fetch embeddings → PCA → overlay. Clicking
29
+
on the map adds training points. The classify button runs kNN and
30
+
updates the overlay.
35
31
36
32
{@ocaml x[
37
-
(* Shared state *)
38
-
let bbox : Geotessera.bbox option ref = ref None
39
-
let mosaic : (Linalg.mat * int * int) option ref = ref None
40
-
let mosaic_bounds : Geotessera.bbox option ref = ref None
41
-
let projected : Linalg.mat option ref = ref None
42
-
let training_points : (float * float * int) list ref = ref []
43
-
let current_class = ref 0
44
-
let class_names = ref [| "water"; "land" |]
33
+
(* --- Configuration --- *)
34
+
35
+
let map_id = "tessera-map"
45
36
let class_colors = [| "#2196F3"; "#4CAF50"; "#FF9800"; "#9C27B0"; "#F44336";
46
37
"#00BCD4"; "#795548"; "#607D8B" |]
47
38
48
-
(* Downsample a mosaic to at most max_pixels, preserving aspect ratio *)
49
-
let downsample_mosaic mat ~h ~w ~max_pixels =
50
-
let n_pixels = h * w in
51
-
if n_pixels <= max_pixels then (mat, h, w)
52
-
else
53
-
let stride = int_of_float (ceil (sqrt (float_of_int n_pixels /. float_of_int max_pixels))) in
54
-
let h' = (h + stride - 1) / stride in
55
-
let w' = (w + stride - 1) / stride in
56
-
let out = Linalg.create_mat ~rows:(h' * w') ~cols:mat.Linalg.cols in
57
-
for i = 0 to h' - 1 do
58
-
for j = 0 to w' - 1 do
59
-
let si = min (i * stride) (h - 1) in
60
-
let sj = min (j * stride) (w - 1) in
61
-
let src = si * w + sj in
62
-
let dst = i * w' + j in
63
-
for f = 0 to mat.Linalg.cols - 1 do
64
-
Linalg.mat_set out dst f (Linalg.mat_get mat src f)
65
-
done
66
-
done
67
-
done;
68
-
(out, h', w')
69
-
70
-
let map_id = "tessera-map"
39
+
(* --- Status display --- *)
71
40
72
41
let status_view text =
73
42
let open Widget.View in
···
76
45
77
46
let () = Widget.display ~id:"status" ~handlers:[] (status_view "Draw a rectangle on the map.")
78
47
48
+
(* --- Signals: bbox from map draw events --- *)
49
+
50
+
let bbox_signal, set_bbox =
51
+
Note.S.create ~eq:(fun a b -> a = b) (None : Geotessera.bbox option)
52
+
53
+
(* --- Signals: training points from map clicks --- *)
54
+
55
+
let current_class_signal, set_current_class = Note.S.create ~eq:Int.equal 0
56
+
let class_names_signal, set_class_names =
57
+
Note.S.create ~eq:(fun a b -> a = b) [| "water"; "land" |]
58
+
let training_points_signal, set_training_points =
59
+
Note.S.create ~eq:(fun _ _ -> false) ([] : (float * float * int) list)
60
+
61
+
(* --- Map widget --- *)
62
+
79
63
let () =
80
64
Widget.display_managed ~id:map_id
81
65
~kind:"leaflet-map"
···
84
68
"bbox_drawn", (fun v ->
85
69
match v with
86
70
| Some json ->
87
-
let s = Scanf.sscanf json
71
+
let b = Scanf.sscanf json
88
72
{| {"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))
73
+
(fun s w n e -> Geotessera.{ min_lat = s; min_lon = w;
74
+
max_lat = n; max_lon = e }) in
75
+
set_bbox (Some b)
95
76
| None -> ());
96
77
"click", (fun v ->
97
78
match v with
98
79
| 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 -> ()
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))))
80
+
let lat, lng = Scanf.sscanf json
81
+
{| {"lat":%f,"lng":%f}|} (fun a b -> (a, b)) in
82
+
let cls = Note.S.value current_class_signal in
83
+
let points = Note.S.value training_points_signal in
84
+
set_training_points ((lat, lng, cls) :: points);
85
+
let color = class_colors.(cls mod Array.length class_colors) in
86
+
let names = Note.S.value class_names_signal in
87
+
let label = names.(cls) in
88
+
Widget.command ~id:map_id "addMarker"
89
+
(Printf.sprintf {|{"lat":%f,"lng":%f,"color":"%s","label":"%s"}|}
90
+
lat lng color label)
113
91
| None -> ());
114
92
]
115
93
116
94
let () = Widget.command ~id:map_id "enableBboxDraw" ""
117
-
]}
118
95
119
-
{1 Fetch embeddings and visualise}
96
+
(* --- Async pipeline: bbox → fetch → mosaic --- *)
97
+
98
+
type mosaic_data = {
99
+
mat : Linalg.mat;
100
+
h : int;
101
+
w : int;
102
+
bounds : Geotessera.bbox;
103
+
}
120
104
121
-
After drawing your bounding box, run this cell to fetch GeoTessera
122
-
embeddings from the Zarr v3 store and display a PCA false-colour
123
-
visualisation. Only the shards covering your region are fetched —
124
-
much faster than downloading full tiles.
105
+
(* Downsample helper *)
106
+
let downsample mat ~h ~w ~max_pixels =
107
+
let n = h * w in
108
+
if n <= max_pixels then (mat, h, w)
109
+
else
110
+
let stride = int_of_float (ceil (sqrt (float_of_int n /. float_of_int max_pixels))) in
111
+
let h' = (h + stride - 1) / stride in
112
+
let w' = (w + stride - 1) / stride in
113
+
let out = Linalg.create_mat ~rows:(h' * w') ~cols:mat.Linalg.cols in
114
+
for i = 0 to h' - 1 do
115
+
for j = 0 to w' - 1 do
116
+
let si = min (i * stride) (h - 1) in
117
+
let sj = min (j * stride) (w - 1) in
118
+
for f = 0 to mat.Linalg.cols - 1 do
119
+
Linalg.mat_set out (i * w' + j) f
120
+
(Linalg.mat_get mat (si * w + sj) f)
121
+
done
122
+
done
123
+
done;
124
+
(out, h', w')
125
125
126
-
{@ocaml x[
127
-
let () =
128
-
match !bbox with
129
-
| None -> Widget.update ~id:"status" (status_view "Error: draw a bounding box first!")
130
-
| Some b ->
131
-
Widget.update ~id:"status" (status_view "Fetching embeddings from Zarr store...");
132
-
let mat_full, h_full, w_full, mosaic_bbox =
133
-
Tessera_zarr_jsoo.fetch_region_sync b in
134
-
Widget.update ~id:"status"
135
-
(status_view (Printf.sprintf "Fetched %d×%d mosaic. Downsampling..." h_full w_full));
136
-
let mat, h, w = downsample_mosaic mat_full ~h:h_full ~w:w_full ~max_pixels:50_000 in
137
-
mosaic := Some (mat, h, w);
138
-
mosaic_bounds := Some mosaic_bbox;
139
-
let mosaic_south = mosaic_bbox.Geotessera.min_lat in
140
-
let mosaic_north = mosaic_bbox.Geotessera.max_lat in
141
-
let mosaic_west = mosaic_bbox.Geotessera.min_lon in
142
-
let mosaic_east = mosaic_bbox.Geotessera.max_lon in
143
-
Widget.update ~id:"status"
144
-
(status_view (Printf.sprintf "Working at %d×%d (%d pixels). Computing PCA..." h w (h * w)));
145
-
let proj = Tfjs.pca mat ~n_components:3 in
146
-
projected := Some proj;
147
-
let pca_img = Viz.pca_to_rgba ~width:w ~height:h proj in
148
-
let url = Viz_jsoo.to_data_url pca_img in
149
-
Widget.command ~id:map_id "addImageOverlay"
150
-
(Printf.sprintf {|{"url":"%s","bounds":[[%f,%f],[%f,%f]],"opacity":0.7}|}
151
-
url mosaic_south mosaic_west mosaic_north mosaic_east);
152
-
Widget.update ~id:"status"
153
-
(status_view "PCA overlay added. Click on the map to place training points, then run the classification cell.")
126
+
(* The core reactive pipeline: bbox changes → async fetch → mosaic state *)
127
+
let mosaic_signal : mosaic_data Tessera_zarr_jsoo.Frp_async.state Note.signal =
128
+
Tessera_zarr_jsoo.Frp_async.async_bind bbox_signal
129
+
(fun bbox progress ->
130
+
progress "Opening Zarr store...";
131
+
let open Lwt.Syntax in
132
+
let* store = Tessera_zarr_jsoo.open_store () in
133
+
let* (mat_full, h_full, w_full, bounds) =
134
+
Tessera_zarr.fetch_region ~progress ~store bbox in
135
+
progress (Printf.sprintf "Fetched %d×%d. Downsampling..." h_full w_full);
136
+
let (mat, h, w) = downsample mat_full ~h:h_full ~w:w_full ~max_pixels:50_000 in
137
+
Lwt.return { mat; h; w; bounds })
138
+
139
+
(* PCA: runs synchronously when mosaic becomes Ready *)
140
+
let pca_signal : Linalg.mat option Note.signal =
141
+
Note.S.map (function
142
+
| Tessera_zarr_jsoo.Frp_async.Ready m ->
143
+
Some (Tfjs.pca m.mat ~n_components:3)
144
+
| _ -> None
145
+
) mosaic_signal
146
+
147
+
(* --- Overlay: update map when PCA result changes --- *)
148
+
149
+
let _overlay_logr = Note.Logr.create (
150
+
Note.Logr.app (Note.Logr.const (fun pca_opt ->
151
+
match pca_opt, Note.S.value mosaic_signal with
152
+
| Some proj, Tessera_zarr_jsoo.Frp_async.Ready m ->
153
+
let pca_img = Viz.pca_to_rgba ~width:m.w ~height:m.h proj in
154
+
let url = Viz_jsoo.to_data_url pca_img in
155
+
Widget.command ~id:map_id "addImageOverlay"
156
+
(Printf.sprintf {|{"url":"%s","bounds":[[%f,%f],[%f,%f]],"opacity":0.7}|}
157
+
url m.bounds.min_lat m.bounds.min_lon
158
+
m.bounds.max_lat m.bounds.max_lon)
159
+
| _ -> ()
160
+
)) (Note.S.obs pca_signal))
161
+
162
+
let () = Note.Logr.hold _overlay_logr
163
+
164
+
(* --- Status: update status display reactively --- *)
165
+
166
+
let _status_logr = Note.Logr.create (
167
+
Note.Logr.app (Note.Logr.const (fun state ->
168
+
let text = match state with
169
+
| Tessera_zarr_jsoo.Frp_async.Idle ->
170
+
"Draw a rectangle on the map."
171
+
| Tessera_zarr_jsoo.Frp_async.Loading msg ->
172
+
Printf.sprintf "Loading: %s" msg
173
+
| Tessera_zarr_jsoo.Frp_async.Ready m ->
174
+
Printf.sprintf "Ready: %d×%d mosaic. Click to add training points."
175
+
m.h m.w
176
+
| Tessera_zarr_jsoo.Frp_async.Error msg ->
177
+
Printf.sprintf "Error: %s" msg
178
+
in
179
+
Widget.update ~id:"status" (status_view text)
180
+
)) (Note.S.obs mosaic_signal))
181
+
182
+
let () = Note.Logr.hold _status_logr
154
183
]}
155
184
156
185
{1 Label training points}
157
186
158
187
Click on the map to add training points. Use the buttons below to
159
-
switch between classes before clicking.
188
+
switch between classes.
160
189
161
190
{@ocaml x[
162
191
let make_class_buttons () =
163
192
let open Widget.View in
193
+
let names = Note.S.value class_names_signal in
194
+
let cls = Note.S.value current_class_signal in
164
195
let buttons = Array.to_list (Array.mapi (fun i name ->
165
196
let color = class_colors.(i mod Array.length class_colors) in
166
-
let border = if i = !current_class then "3px solid black" else "1px solid #ccc" in
197
+
let border = if i = cls then "3px solid black" else "1px solid #ccc" in
167
198
Element { tag = "button";
168
199
attrs = [
169
200
Handler ("click", "class_" ^ string_of_int i);
170
-
Style ("margin", "4px");
171
-
Style ("padding", "8px 16px");
172
-
Style ("background", color);
173
-
Style ("color", "white");
174
-
Style ("border", border);
175
-
Style ("border-radius", "4px");
201
+
Style ("margin", "4px"); Style ("padding", "8px 16px");
202
+
Style ("background", color); Style ("color", "white");
203
+
Style ("border", border); Style ("border-radius", "4px");
176
204
Style ("cursor", "pointer");
177
205
];
178
206
children = [Text name] }
179
-
) !class_names) in
207
+
) names) in
180
208
Element { tag = "div";
181
209
attrs = [Style ("padding", "8px")];
182
210
children =
183
211
Element { tag = "b"; attrs = []; children = [Text "Active class: "] }
184
212
:: buttons
185
213
@ [Element { tag = "button";
186
-
attrs = [
187
-
Handler ("click", "add_class");
188
-
Style ("margin", "4px");
189
-
Style ("padding", "8px 16px");
190
-
Style ("border", "1px dashed #999");
191
-
Style ("border-radius", "4px");
192
-
Style ("cursor", "pointer");
193
-
];
214
+
attrs = [ Handler ("click", "add_class");
215
+
Style ("margin", "4px"); Style ("padding", "8px 16px");
216
+
Style ("border", "1px dashed #999"); Style ("border-radius", "4px");
217
+
Style ("cursor", "pointer") ];
194
218
children = [Text "+ Add class"] };
195
219
Element { tag = "button";
196
-
attrs = [
197
-
Handler ("click", "clear_points");
198
-
Style ("margin", "4px");
199
-
Style ("padding", "8px 16px");
200
-
Style ("border", "1px solid #ccc");
201
-
Style ("border-radius", "4px");
202
-
Style ("cursor", "pointer");
203
-
];
220
+
attrs = [ Handler ("click", "classify");
221
+
Style ("margin", "4px"); Style ("padding", "8px 16px");
222
+
Style ("background", "#FF5722"); Style ("color", "white");
223
+
Style ("border", "none"); Style ("border-radius", "4px");
224
+
Style ("cursor", "pointer"); Style ("font-weight", "bold") ];
225
+
children = [Text "Classify"] };
226
+
Element { tag = "button";
227
+
attrs = [ Handler ("click", "clear_points");
228
+
Style ("margin", "4px"); Style ("padding", "8px 16px");
229
+
Style ("border", "1px solid #ccc"); Style ("border-radius", "4px");
230
+
Style ("cursor", "pointer") ];
204
231
children = [Text "Clear all"] }]
205
232
}
206
233
207
-
let class_handler_list () =
208
-
let base = Array.to_list (Array.mapi (fun i _name ->
209
-
"class_" ^ string_of_int i, (fun (_v : string option) ->
210
-
current_class := i;
211
-
Widget.update ~id:"class-buttons" (make_class_buttons ()))
212
-
) !class_names) in
213
-
base @ [
214
-
"add_class", (fun _v ->
215
-
let n = Array.length !class_names in
216
-
let name = "class_" ^ string_of_int n in
217
-
class_names := Array.append !class_names [| name |];
218
-
current_class := n;
219
-
Widget.update ~id:"class-buttons" (make_class_buttons ()));
220
-
"clear_points", (fun _v ->
221
-
training_points := [];
222
-
Widget.command ~id:map_id "clearMarkers" "";
223
-
Widget.update ~id:"status" (status_view "Cleared all training points."));
224
-
]
225
-
226
234
let () =
227
-
Widget.display ~id:"class-buttons"
228
-
~handlers:(class_handler_list ())
229
-
(make_class_buttons ())
230
-
]}
231
-
232
-
{1 Classify and display}
233
-
234
-
Run this cell after placing training points to classify the entire
235
-
region using k-nearest neighbours.
236
-
237
-
{@ocaml x[
238
-
let () =
239
-
match !mosaic, !projected, !mosaic_bounds with
240
-
| Some (mat, h, w), Some _proj, Some mb ->
241
-
let points = !training_points in
242
-
if points = [] then
243
-
Widget.update ~id:"status" (status_view "Error: place some training points first!")
244
-
else begin
245
-
Widget.update ~id:"status"
246
-
(status_view (Printf.sprintf "Classifying with %d training points..." (List.length points)));
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
-
let n_train = List.length points in
252
-
let train_mat = Linalg.create_mat ~rows:n_train ~cols:mat.Linalg.cols in
253
-
let train_labels = Array.make n_train 0 in
254
-
List.iteri (fun i (lat, lng, cls) ->
255
-
let row = int_of_float ((mosaic_north -. lat) /. (mosaic_north -. mosaic_south) *. float_of_int h) in
256
-
let col = int_of_float ((lng -. mosaic_west) /. (mosaic_east -. mosaic_west) *. float_of_int w) in
257
-
let row = max 0 (min (h - 1) row) in
258
-
let col = max 0 (min (w - 1) col) in
259
-
let src_offset = (row * w + col) * mat.Linalg.cols in
260
-
let dst_offset = i * mat.Linalg.cols in
261
-
for j = 0 to mat.Linalg.cols - 1 do
262
-
Bigarray.Array1.set train_mat.Linalg.data (dst_offset + j)
263
-
(Bigarray.Array1.get mat.Linalg.data (src_offset + j))
264
-
done;
265
-
train_labels.(i) <- cls
266
-
) points;
267
-
let model = Linalg.knn_fit ~embeddings:train_mat ~labels:train_labels in
268
-
let k = min 5 n_train in
269
-
let result = Linalg.knn_predict model ~k mat in
270
-
let n_classes = Array.fold_left max 0 train_labels + 1 in
271
-
let colors = List.init n_classes (fun i ->
272
-
let hex = class_colors.(i mod Array.length class_colors) in
273
-
(i, Viz.color_of_hex hex)
274
-
) in
275
-
let class_img = Viz.classification_to_rgba
276
-
~predictions:result.Linalg.predictions
277
-
~colors ~width:w ~height:h () in
278
-
let class_url = Viz_jsoo.to_data_url class_img in
279
-
Widget.command ~id:map_id "addImageOverlay"
280
-
(Printf.sprintf {|{"url":"%s","bounds":[[%f,%f],[%f,%f]],"opacity":0.7}|}
281
-
class_url mosaic_south mosaic_west mosaic_north mosaic_east);
282
-
Widget.update ~id:"status"
283
-
(status_view (Printf.sprintf "Classification complete! %d classes, %d training points."
284
-
n_classes n_train))
285
-
end
286
-
| _ ->
287
-
Widget.update ~id:"status" (status_view "Error: fetch embeddings first!")
235
+
let names = Note.S.value class_names_signal in
236
+
let handlers =
237
+
Array.to_list (Array.mapi (fun i _name ->
238
+
"class_" ^ string_of_int i, (fun (_v : string option) ->
239
+
set_current_class i;
240
+
Widget.update ~id:"class-buttons" (make_class_buttons ()))
241
+
) names)
242
+
@ [
243
+
"add_class", (fun _v ->
244
+
let names = Note.S.value class_names_signal in
245
+
let n = Array.length names in
246
+
set_class_names (Array.append names [| "class_" ^ string_of_int n |]);
247
+
set_current_class n;
248
+
Widget.update ~id:"class-buttons" (make_class_buttons ()));
249
+
"classify", (fun _v ->
250
+
let points = Note.S.value training_points_signal in
251
+
(match Note.S.value mosaic_signal with
252
+
| Tessera_zarr_jsoo.Frp_async.Ready m when points <> [] ->
253
+
Widget.update ~id:"status"
254
+
(status_view (Printf.sprintf "Classifying with %d points..." (List.length points)));
255
+
let n_train = List.length points in
256
+
let train_mat = Linalg.create_mat ~rows:n_train ~cols:m.mat.Linalg.cols in
257
+
let train_labels = Array.make n_train 0 in
258
+
List.iteri (fun i (lat, lng, cls) ->
259
+
let row = int_of_float ((m.bounds.max_lat -. lat) /.
260
+
(m.bounds.max_lat -. m.bounds.min_lat) *. float_of_int m.h) in
261
+
let col = int_of_float ((lng -. m.bounds.min_lon) /.
262
+
(m.bounds.max_lon -. m.bounds.min_lon) *. float_of_int m.w) in
263
+
let row = max 0 (min (m.h - 1) row) in
264
+
let col = max 0 (min (m.w - 1) col) in
265
+
let src = (row * m.w + col) * m.mat.Linalg.cols in
266
+
let dst = i * m.mat.Linalg.cols in
267
+
for j = 0 to m.mat.Linalg.cols - 1 do
268
+
Bigarray.Array1.set train_mat.Linalg.data (dst + j)
269
+
(Bigarray.Array1.get m.mat.Linalg.data (src + j))
270
+
done;
271
+
train_labels.(i) <- cls
272
+
) points;
273
+
let model = Linalg.knn_fit ~embeddings:train_mat ~labels:train_labels in
274
+
let k = min 5 n_train in
275
+
let result = Linalg.knn_predict model ~k m.mat in
276
+
let n_classes = Array.fold_left max 0 train_labels + 1 in
277
+
let colors = List.init n_classes (fun i ->
278
+
(i, Viz.color_of_hex class_colors.(i mod Array.length class_colors))) in
279
+
let img = Viz.classification_to_rgba
280
+
~predictions:result.Linalg.predictions
281
+
~colors ~width:m.w ~height:m.h () in
282
+
let url = Viz_jsoo.to_data_url img in
283
+
Widget.command ~id:map_id "addImageOverlay"
284
+
(Printf.sprintf {|{"url":"%s","bounds":[[%f,%f],[%f,%f]],"opacity":0.7}|}
285
+
url m.bounds.min_lat m.bounds.min_lon
286
+
m.bounds.max_lat m.bounds.max_lon);
287
+
Widget.update ~id:"status"
288
+
(status_view (Printf.sprintf "Classification complete! %d classes, %d points."
289
+
n_classes n_train))
290
+
| _ ->
291
+
Widget.update ~id:"status" (status_view "Need mosaic + training points first.")));
292
+
"clear_points", (fun _v ->
293
+
set_training_points [];
294
+
Widget.command ~id:map_id "clearMarkers" "";
295
+
Widget.update ~id:"status" (status_view "Cleared all training points."));
296
+
]
297
+
in
298
+
Widget.display ~id:"class-buttons" ~handlers (make_class_buttons ())
288
299
]}