TESSERA Interactive Map (Zarr)
Explore geospatial embeddings from the GeoTessera foundation model directly in the browser. This version uses the GeoTessera Zarr v3 store (MegaZarr format — single store with year as a dimension) and a reactive (FRP) architecture — drawing a bounding box automatically triggers fetching, PCA visualisation, and overlay updates.
#require "tessera-zarr-jsoo";;
#require "tessera-viz-jsoo";;
#require "tessera-tfjs";;
#require "js_top_worker-widget-leaflet";;
open Widget_leaflet;;
register ();;
(* Load fzstd (Zstd decompressor) and TensorFlow.js *)
let () =
let open Js_of_ocaml in
let import url : unit = Js.Unsafe.fun_call
(Js.Unsafe.get Js.Unsafe.global (Js.string "importScripts"))
[| Js.Unsafe.inject (Js.string url) |] in
import "https://cdn.jsdelivr.net/npm/fzstd@0.1.1/umd/index.js";
import "https://cdn.jsdelivr.net/npm/@tensorflow/tfjs@4/dist/tf.min.js"Reactive pipeline
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.
let class_colors = [| "#2196F3"; "#4CAF50"; "#FF9800"; "#9C27B0"; "#F44336";
"#00BCD4"; "#795548"; "#607D8B" |]
(* --- Status display --- *)
let status_view text =
let open Widget.View in
Element { tag = "div"; attrs = [Style ("padding", "8px"); Style ("font-family", "monospace")];
children = [Text text] }
let () = Widget.display ~id:"status" ~handlers:[] (status_view "Draw a rectangle on the map.")
(* --- FRP signals --- *)
let bbox_signal, set_bbox =
Note.S.create ~eq:(fun a b -> a = b) (None : Geotessera.bbox option)
let year_signal, set_year = Note.S.create ~eq:Int.equal 2024
let current_class_signal, set_current_class = Note.S.create ~eq:Int.equal 0
let class_names_signal, set_class_names =
Note.S.create ~eq:(fun a b -> a = b) [| "water"; "land" |]
let training_points_signal, set_training_points =
Note.S.create ~eq:(fun _ _ -> false) ([] : (float * float * int) list)
(* --- Map widget (typed interface) --- *)
let () = Widget.display ~id:"debug" ~handlers:[] (status_view "No bbox drawn yet.")
let map_ref : Leaflet_map.t option ref = ref None
let map_get () = match !map_ref with Some m -> m | None -> failwith "map not ready"
let map = Leaflet_map.create
~center:(52.2, 0.12) ~zoom:13 ~height:"500px"
~on_move:(fun info ->
Widget.update ~id:"status"
(status_view (Printf.sprintf "Center: %.5f, %.5f Zoom: %d Bounds: S%.5f W%.5f N%.5f E%.5f"
info.center.lat info.center.lng info.zoom
info.bounds.south info.bounds.west info.bounds.north info.bounds.east)))
~on_bbox_drawn:(fun b ->
Widget.update ~id:"debug"
(status_view (Printf.sprintf "Drawn bbox: S%.5f W%.5f N%.5f E%.5f"
b.south b.west b.north b.east));
set_bbox (Some Geotessera.{
min_lat = b.south; min_lon = b.west;
max_lat = b.north; max_lon = b.east }))
~on_click:(fun pt ->
let cls = Note.S.value current_class_signal in
let points = Note.S.value training_points_signal in
set_training_points ((pt.lat, pt.lng, cls) :: points);
let color = class_colors.(cls mod Array.length class_colors) in
let names = Note.S.value class_names_signal in
Leaflet_map.add_marker (map_get ()) pt ~color ~label:names.(cls) ())
()
let () = map_ref := Some map
let () = Leaflet_map.enable_bbox_draw map
(* --- Async pipeline: bbox → fetch → mosaic --- *)
type mosaic_data = {
mat : Linalg.mat;
h : int;
w : int;
bounds : Leaflet_map.bounds;
}
let downsample mat ~h ~w ~max_pixels =
let n = h * w in
if n <= max_pixels then (mat, h, w)
else
let stride = int_of_float (ceil (sqrt (float_of_int n /. float_of_int max_pixels))) in
let h' = (h + stride - 1) / stride in
let w' = (w + stride - 1) / stride in
let out = Linalg.create_mat ~rows:(h' * w') ~cols:mat.Linalg.cols in
for i = 0 to h' - 1 do
for j = 0 to w' - 1 do
let si = min (i * stride) (h - 1) in
let sj = min (j * stride) (w - 1) in
for f = 0 to mat.Linalg.cols - 1 do
Linalg.mat_set out (i * w' + j) f
(Linalg.mat_get mat (si * w + sj) f)
done
done
done;
(out, h', w')
let bbox_year_signal =
Note.S.l2 (fun b y -> Option.map (fun b -> (b, y)) b) bbox_signal year_signal
let mosaic_signal : mosaic_data Tessera_zarr_jsoo.Frp_async.state Note.signal =
Tessera_zarr_jsoo.Frp_async.async_bind bbox_year_signal
(fun (bbox, year) progress ->
progress (Printf.sprintf "Opening MegaZarr store (year %d)..." year);
let open Lwt.Syntax in
let* store = Tessera_zarr_jsoo.open_store ~year () in
let* (mat_full, h_full, w_full, geo_bounds) =
Tessera_zarr.fetch_region ~progress ~year ~store bbox in
progress (Printf.sprintf "Fetched %d×%d. Downsampling..." h_full w_full);
let (mat, h, w) = downsample mat_full ~h:h_full ~w:w_full ~max_pixels:1_000_000 in
let bounds = Leaflet_map.{
south = geo_bounds.Geotessera.min_lat;
north = geo_bounds.Geotessera.max_lat;
west = geo_bounds.Geotessera.min_lon;
east = geo_bounds.Geotessera.max_lon;
} in
Lwt.return { mat; h; w; bounds })
(* PCA: runs when mosaic becomes Ready *)
let pca_signal : Linalg.mat option Note.signal =
Note.S.map (function
| Tessera_zarr_jsoo.Frp_async.Ready m ->
Some (Tfjs.pca m.mat ~n_components:3)
| _ -> None
) mosaic_signal
(* Overlay: update map when PCA result changes *)
let _overlay_logr =
let logr = Note.Logr.create (
Note.Logr.app (Note.Logr.const (fun pca_opt ->
match pca_opt, Note.S.value mosaic_signal with
| Some proj, Tessera_zarr_jsoo.Frp_async.Ready m ->
let img = Viz.pca_to_rgba ~width:m.w ~height:m.h proj in
let url = Viz_jsoo.to_data_url img in
Leaflet_map.add_image_overlay map ~url ~bounds:m.bounds ~opacity:0.7 ()
| _ -> ()
)) (Note.S.obs pca_signal))
in Note.Logr.hold logr
(* Status: update display reactively *)
let _status_logr =
let logr = Note.Logr.create (
Note.Logr.app (Note.Logr.const (fun state ->
let text = match state with
| Tessera_zarr_jsoo.Frp_async.Idle ->
"Draw a rectangle on the map."
| Loading msg -> Printf.sprintf "Loading: %s" msg
| Ready m ->
Printf.sprintf "Ready: %d×%d mosaic. Click to add training points." m.h m.w
| Error msg -> Printf.sprintf "Error: %s" msg
in
Widget.update ~id:"status" (status_view text)
)) (Note.S.obs mosaic_signal))
in Note.Logr.hold logrYear selection
Select the year for the GeoTessera embeddings (2017–2025). Changing the year re-fetches the current bounding box.
let make_year_buttons () =
let open Widget.View in
let current = Note.S.value year_signal in
let buttons = List.map (fun y ->
let border = if y = current then "3px solid black" else "1px solid #ccc" in
Element { tag = "button";
attrs = [
Handler ("click", "year_" ^ string_of_int y);
Style ("margin", "2px"); Style ("padding", "6px 12px");
Style ("border", border); Style ("border-radius", "4px");
Style ("cursor", "pointer");
];
children = [Text (string_of_int y)] }
) [2017; 2018; 2019; 2020; 2021; 2022; 2023; 2024; 2025] in
Element { tag = "div";
attrs = [Style ("padding", "8px")];
children = Element { tag = "b"; attrs = []; children = [Text "Year: "] } :: buttons }
let () =
let handlers = List.map (fun y ->
"year_" ^ string_of_int y, (fun (_v : string option) ->
set_year y;
Widget.update ~id:"year-buttons" (make_year_buttons ()))
) [2017; 2018; 2019; 2020; 2021; 2022; 2023; 2024; 2025] in
Widget.display ~id:"year-buttons" ~handlers (make_year_buttons ())Label training points
Click on the map to add training points. Use the buttons below to switch classes, classify, or clear.
let make_class_buttons () =
let open Widget.View in
let names = Note.S.value class_names_signal in
let cls = Note.S.value current_class_signal in
let buttons = Array.to_list (Array.mapi (fun i name ->
let color = class_colors.(i mod Array.length class_colors) in
let border = if i = cls then "3px solid black" else "1px solid #ccc" in
Element { tag = "button";
attrs = [
Handler ("click", "class_" ^ string_of_int i);
Style ("margin", "4px"); Style ("padding", "8px 16px");
Style ("background", color); Style ("color", "white");
Style ("border", border); Style ("border-radius", "4px");
Style ("cursor", "pointer");
];
children = [Text name] }
) names) in
Element { tag = "div";
attrs = [Style ("padding", "8px")];
children =
Element { tag = "b"; attrs = []; children = [Text "Active class: "] }
:: buttons
@ [Element { tag = "button";
attrs = [ Handler ("click", "add_class");
Style ("margin", "4px"); Style ("padding", "8px 16px");
Style ("border", "1px dashed #999"); Style ("border-radius", "4px");
Style ("cursor", "pointer") ];
children = [Text "+ Add class"] };
Element { tag = "button";
attrs = [ Handler ("click", "classify");
Style ("margin", "4px"); Style ("padding", "8px 16px");
Style ("background", "#FF5722"); Style ("color", "white");
Style ("border", "none"); Style ("border-radius", "4px");
Style ("cursor", "pointer"); Style ("font-weight", "bold") ];
children = [Text "Classify"] };
Element { tag = "button";
attrs = [ Handler ("click", "clear_points");
Style ("margin", "4px"); Style ("padding", "8px 16px");
Style ("border", "1px solid #ccc"); Style ("border-radius", "4px");
Style ("cursor", "pointer") ];
children = [Text "Clear all"] }]
}
let () =
let names = Note.S.value class_names_signal in
let handlers =
Array.to_list (Array.mapi (fun i _name ->
"class_" ^ string_of_int i, (fun (_v : string option) ->
set_current_class i;
Widget.update ~id:"class-buttons" (make_class_buttons ()))
) names)
@ [
"add_class", (fun _v ->
let names = Note.S.value class_names_signal in
let n = Array.length names in
set_class_names (Array.append names [| "class_" ^ string_of_int n |]);
set_current_class n;
Widget.update ~id:"class-buttons" (make_class_buttons ()));
"classify", (fun _v ->
let points = Note.S.value training_points_signal in
(match Note.S.value mosaic_signal with
| Tessera_zarr_jsoo.Frp_async.Ready m when points <> [] ->
Widget.update ~id:"status"
(status_view (Printf.sprintf "Classifying with %d points..." (List.length points)));
let n_train = List.length points in
let train_mat = Linalg.create_mat ~rows:n_train ~cols:m.mat.Linalg.cols in
let train_labels = Array.make n_train 0 in
List.iteri (fun i (lat, lng, cls) ->
let row = int_of_float ((m.bounds.north -. lat) /.
(m.bounds.north -. m.bounds.south) *. float_of_int m.h) in
let col = int_of_float ((lng -. m.bounds.west) /.
(m.bounds.east -. m.bounds.west) *. float_of_int m.w) in
let row = max 0 (min (m.h - 1) row) in
let col = max 0 (min (m.w - 1) col) in
let src = (row * m.w + col) * m.mat.Linalg.cols in
let dst = i * m.mat.Linalg.cols in
for j = 0 to m.mat.Linalg.cols - 1 do
Bigarray.Array1.set train_mat.Linalg.data (dst + j)
(Bigarray.Array1.get m.mat.Linalg.data (src + j))
done;
train_labels.(i) <- cls
) points;
let model = Linalg.knn_fit ~embeddings:train_mat ~labels:train_labels in
let k = min 5 n_train in
let result = Linalg.knn_predict model ~k m.mat in
let n_classes = Array.fold_left max 0 train_labels + 1 in
let colors = List.init n_classes (fun i ->
(i, Viz.color_of_hex class_colors.(i mod Array.length class_colors))) in
let img = Viz.classification_to_rgba
~predictions:result.Linalg.predictions
~colors ~width:m.w ~height:m.h () in
let url = Viz_jsoo.to_data_url img in
Leaflet_map.add_image_overlay map ~url ~bounds:m.bounds ~opacity:0.7 ();
Widget.update ~id:"status"
(status_view (Printf.sprintf "Classification complete! %d classes, %d points."
n_classes n_train))
| _ ->
Widget.update ~id:"status" (status_view "Need mosaic + training points first.")));
"clear_points", (fun _v ->
set_training_points [];
Leaflet_map.clear_markers map;
Widget.update ~id:"status" (status_view "Cleared all training points."));
]
in
Widget.display ~id:"class-buttons" ~handlers (make_class_buttons ())