TESSERA Interactive Map
Explore geospatial embeddings from the GeoTessera foundation model directly in the browser. This notebook walks through a complete land-cover classification workflow:
- Draw a bounding box to select your region of interest
- Fetch and visualise GeoTessera embeddings with PCA
- Click on the map to place labelled training points
- Run k-nearest-neighbours classification
- View the classification overlay
#require "tessera-geotessera-jsoo";;
#require "tessera-viz-jsoo";;
#require "tessera-tfjs";;
#require "js_top_worker-widget-leaflet";;
open Widget_leaflet;;
register ();;
(* Load TensorFlow.js in the worker *)
let () =
let open Js_of_ocaml in
Js.Unsafe.fun_call
(Js.Unsafe.get Js.Unsafe.global (Js.string "importScripts"))
[| Js.Unsafe.inject (Js.string "https://cdn.jsdelivr.net/npm/@tensorflow/tfjs@4/dist/tf.min.js") |]Select region of interest
Draw a rectangle on the map to select the area you want to classify. The map is centred on Cambridge, UK — navigate to any area of interest before drawing.
(* Shared state *)
let bbox : Geotessera.bbox option ref = ref None
let mosaic : (Linalg.mat * int * int) option ref = ref None
let mosaic_bounds : Leaflet_map.bounds option ref = ref None
let projected : Linalg.mat option ref = ref None
let training_points : (float * float * int) list ref = ref []
let current_class = ref 0
let class_names = ref [| "water"; "land" |]
let class_colors = [| "#2196F3"; "#4CAF50"; "#FF9800"; "#9C27B0"; "#F44336";
"#00BCD4"; "#795548"; "#607D8B" |]
(* Downsample a mosaic to at most max_pixels, preserving aspect ratio *)
let downsample_mosaic mat ~h ~w ~max_pixels =
let n_pixels = h * w in
if n_pixels <= max_pixels then (mat, h, w)
else
let stride = int_of_float (ceil (sqrt (float_of_int n_pixels /. 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
let src = si * w + sj in
let dst = i * w' + j in
for f = 0 to mat.Linalg.cols - 1 do
Linalg.mat_set out dst f (Linalg.mat_get mat src f)
done
done
done;
(out, h', w')
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.")
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_bbox_drawn:(fun b ->
bbox := Some Geotessera.{
min_lat = b.south; min_lon = b.west;
max_lat = b.north; max_lon = b.east };
Widget.update ~id:"status"
(status_view (Printf.sprintf "Selected: %.4f,%.4f to %.4f,%.4f — run next cell to fetch embeddings."
b.south b.west b.north b.east)))
~on_click:(fun pt ->
match !mosaic with
| None -> ()
| Some _ ->
let cls = !current_class in
training_points := (pt.lat, pt.lng, cls) :: !training_points;
let color = class_colors.(cls mod Array.length class_colors) in
let label = (!class_names).(cls) in
Leaflet_map.add_marker (map_get ()) pt ~color ~label ();
Widget.update ~id:"status"
(status_view (Printf.sprintf "Added %s point at %.4f, %.4f (%d points total)"
label pt.lat pt.lng (List.length !training_points))))
()
let () = map_ref := Some map
let () = Leaflet_map.enable_bbox_draw mapFetch embeddings and visualise
After drawing your bounding box, run this cell to fetch GeoTessera embeddings and display a PCA false-colour visualisation.
let () =
match !bbox with
| None -> Widget.update ~id:"status" (status_view "Error: draw a bounding box first!")
| Some b ->
Widget.update ~id:"status" (status_view "Fetching embeddings...");
let mat_full, h_full, w_full, geo_bbox = Geotessera_jsoo.fetch_mosaic ~year:2024 b in
Widget.update ~id:"status"
(status_view (Printf.sprintf "Fetched %d×%d mosaic. Downsampling..." h_full w_full));
let mat, h, w = downsample_mosaic mat_full ~h:h_full ~w:w_full ~max_pixels:200_000 in
mosaic := Some (mat, h, w);
let bounds = Leaflet_map.{
south = geo_bbox.Geotessera.min_lat;
north = geo_bbox.Geotessera.max_lat;
west = geo_bbox.Geotessera.min_lon;
east = geo_bbox.Geotessera.max_lon;
} in
mosaic_bounds := Some bounds;
Widget.update ~id:"status"
(status_view (Printf.sprintf "Working at %d×%d (%d pixels). Computing PCA..." h w (h * w)));
(* PCA to 3 components for RGB visualisation (via TensorFlow.js SVD) *)
let proj = Tfjs.pca mat ~n_components:3 in
projected := Some proj;
let pca_img = Viz.pca_to_rgba ~width:w ~height:h proj in
let url = Viz_jsoo.to_data_url pca_img in
Leaflet_map.add_image_overlay map ~url ~bounds ~opacity:0.7 ();
Widget.update ~id:"status"
(status_view "PCA overlay added. Click on the map to place training points, then run the classification cell.")Label training points
Click on the map to add training points. Use the buttons below to switch between classes before clicking.
let make_class_buttons () =
let open Widget.View 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 = !current_class 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] }
) !class_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", "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 class_handler_list () =
let base = Array.to_list (Array.mapi (fun i _name ->
"class_" ^ string_of_int i, (fun (_v : string option) ->
current_class := i;
Widget.update ~id:"class-buttons" (make_class_buttons ()))
) !class_names) in
base @ [
"add_class", (fun _v ->
let n = Array.length !class_names in
let name = "class_" ^ string_of_int n in
class_names := Array.append !class_names [| name |];
current_class := n;
Widget.update ~id:"class-buttons" (make_class_buttons ()));
"clear_points", (fun _v ->
training_points := [];
Leaflet_map.clear_markers map;
Widget.update ~id:"status" (status_view "Cleared all training points."));
]
let () =
Widget.display ~id:"class-buttons"
~handlers:(class_handler_list ())
(make_class_buttons ())Classify and display
Run this cell after placing training points to classify the entire region using k-nearest neighbours.
let () =
match !mosaic, !projected, !mosaic_bounds with
| Some (mat, h, w), Some _proj, Some bounds ->
let points = !training_points in
if points = [] then
Widget.update ~id:"status" (status_view "Error: place some training points first!")
else begin
Widget.update ~id:"status"
(status_view (Printf.sprintf "Classifying with %d training points..." (List.length points)));
let n_train = List.length points in
let train_mat = Linalg.create_mat ~rows:n_train ~cols: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 ((bounds.north -. lat) /.
(bounds.north -. bounds.south) *. float_of_int h) in
let col = int_of_float ((lng -. bounds.west) /.
(bounds.east -. bounds.west) *. float_of_int w) in
let row = max 0 (min (h - 1) row) in
let col = max 0 (min (w - 1) col) in
let src_offset = (row * w + col) * mat.Linalg.cols in
let dst_offset = i * mat.Linalg.cols in
for j = 0 to mat.Linalg.cols - 1 do
Bigarray.Array1.set train_mat.Linalg.data (dst_offset + j)
(Bigarray.Array1.get mat.Linalg.data (src_offset + 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 mat in
let n_classes = Array.fold_left max 0 train_labels + 1 in
let colors = List.init n_classes (fun i ->
let hex = class_colors.(i mod Array.length class_colors) in
(i, Viz.color_of_hex hex)
) in
let class_img = Viz.classification_to_rgba
~predictions:result.Linalg.predictions
~colors ~width:w ~height:h () in
let class_url = Viz_jsoo.to_data_url class_img in
Leaflet_map.add_image_overlay map ~url:class_url ~bounds ~opacity:0.7 ();
Widget.update ~id:"status"
(status_view (Printf.sprintf "Classification complete! %d classes, %d training points."
n_classes n_train))
end
| _ ->
Widget.update ~id:"status" (status_view "Error: fetch embeddings first!")