Add near Search Param for Location Resource

Signed-off-by: Jonas Wagner <jwagner@knoppiks.de>

Author: knoppiks

docs/api/interaction/search-type.md

@@ -40,6 +40,10 @@ Search for `Resource.meta.profile` is supported using the `_profile` search para
 
 When searching for date/time with a search parameter value without timezone like `2024` or `2024-02-16`, Blaze calculates the range of the search parameter values based on [UTC][2]. That means that a resource with a date/time value staring at `2024-01-01T00:00:00+01:00` will be not found by a search with `2024`. Please comment on [issue #1498](https://github.com/samply/blaze/issues/1498) if you like to have this situation improved.
 
+## Geospatial Search
+
+When searching for Locations using the `near` modifier, Blaze uses the [Haversine formula](https://en.wikipedia.org/wiki/Haversine_formula) to calculate the distance between the search parameter value and the resource's location, which simplifies by assuming a spherical earth and has an error of less than approximately 0.5%.
+
 ## Sorting
 
 The special search parameter `_sort` supports the values `_id`, `_lastUpdated` and `-_lastUpdated`.

modules/db/src/blaze/db/impl/search_param.clj

@@ -13,6 +13,7 @@
    [blaze.db.impl.search-param.date]
    [blaze.db.impl.search-param.has]
    [blaze.db.impl.search-param.list]
+   [blaze.db.impl.search-param.near]
    [blaze.db.impl.search-param.number]
    [blaze.db.impl.search-param.quantity]
    [blaze.db.impl.search-param.string]

modules/db/src/blaze/db/impl/search_param/near.clj

@@ -0,0 +1,130 @@
+(ns blaze.db.impl.search-param.near
+  (:require
+   [blaze.anomaly :as ba :refer [when-ok]]
+   [blaze.async.comp :as ac]
+   [blaze.coll.core :as coll]
+   [blaze.db.api :as d]
+   [blaze.db.impl.index.index-handle :as ih]
+   [blaze.db.impl.index.single-version-id :as svi]
+   [blaze.db.impl.protocols :as p]
+   [blaze.db.impl.search-param.near.geo :as spng]
+   [blaze.db.impl.search-param.special :as special]
+   [blaze.db.impl.search-param.util :as u]
+   [blaze.fhir.spec.type.system :as system]
+   [clojure.string :as str]
+   [cognitect.anomalies :as anom]))
+
+(set! *warn-on-reflection* true)
+
+(defn- matches? [batch-db resource-handle values]
+  (-> (d/pull batch-db resource-handle)
+      (ac/then-apply
+       (fn [{:keys [position]}]
+         (some (fn [{:keys [distance] :as value}]
+                 (spng/near? position value distance)) values)))
+      (ac/join)))
+
+(defn- unsupported-unit-msg [unit code]
+  (format "Unsupported unit `%s` in search parameter `%s`. Supported are 'km', 'm'." unit code))
+
+(defn- missing-param-msg [arg code]
+  (format "Missing argument `%s` in search parameter `%s`." arg code))
+
+(defn- param-parsing-err-msg [arg code]
+  (format "Error parsing argument `%s` in search parameter `%s`." arg code))
+
+(defn- update-msg [msg]
+  (fn [anomaly]
+    (update anomaly ::anom/message #(str msg " " %))))
+
+(defn- parse-dec-arg [coord name code]
+  (when-ok [_ (when (str/blank? coord)
+                (ba/incorrect (missing-param-msg name code)))]
+    (-> (system/parse-decimal coord)
+        (ba/exceptionally (update-msg (param-parsing-err-msg name code))))))
+
+(defn- distance-in-meters [dist unit code]
+  (cond
+    (str/blank? dist)
+    1000M
+
+    (or (nil? unit) (= unit "km"))
+    (when-ok [dist (parse-dec-arg dist "distance" code)]
+      (* dist 1000))
+
+    (= unit "m")
+    (parse-dec-arg dist "distance" code)
+
+    :else
+    (ba/incorrect (unsupported-unit-msg unit code))))
+
+(defrecord SearchParamNear [index name type code]
+  p/SearchParam
+  (-validate-modifier [_ modifier]
+    (some->> modifier (u/unknown-modifier-anom code)))
+
+  (-compile-value [_ _ value]
+    (let [[lat long dist unit] (str/split value #"\|" 4)]
+      (when-ok [parsed-lat (parse-dec-arg lat "latitude" code)
+                parsed-long (parse-dec-arg long "longitude" code)
+                meters (distance-in-meters dist unit code)]
+        {:latitude parsed-lat
+         :longitude parsed-long
+         :distance meters})))
+
+  (-estimated-scan-size [_ _ _ _ _]
+    (ba/unsupported))
+
+  (-supports-ordered-index-handles [_ _ _ _ _]
+    true)
+
+  (-ordered-index-handles [search-param batch-db tid modifier compiled-values]
+    (if (= 1 (count compiled-values))
+      (p/-index-handles search-param batch-db tid modifier (first compiled-values))
+      (let [index-handles #(p/-index-handles search-param batch-db tid modifier %)]
+        (u/union-index-handles (map index-handles compiled-values)))))
+
+  (-ordered-index-handles [search-param batch-db tid modifier compiled-values start-id]
+    (if (= 1 (count compiled-values))
+      (p/-index-handles search-param batch-db tid modifier (first compiled-values) start-id)
+      (let [index-handles #(p/-index-handles search-param batch-db tid modifier % start-id)]
+        (u/union-index-handles (map index-handles compiled-values)))))
+
+  (-index-handles [search-param batch-db tid modifier compiled-value]
+    (coll/eduction
+     (comp (p/-matcher search-param batch-db modifier [compiled-value])
+           (map ih/from-resource-handle))
+     (d/type-list batch-db tid)))
+
+  (-index-handles [search-param batch-db tid modifier compiled-value start-id]
+    (coll/eduction
+     (comp (p/-matcher search-param batch-db modifier [compiled-value])
+           (map ih/from-resource-handle))
+     (d/type-list batch-db tid start-id)))
+
+  (-supports-ordered-compartment-index-handles [_ _]
+    false)
+
+  (-ordered-compartment-index-handles [_ _ _ _ _]
+    (ba/unsupported))
+
+  (-ordered-compartment-index-handles [_ _ _ _ _ _]
+    (ba/unsupported))
+
+  (-matcher [_ batch-db _ compiled-values]
+    (filter #(matches? batch-db % compiled-values)))
+
+  (-single-version-id-matcher [search-param batch-db tid modifier compiled-values]
+    (comp (map ih/from-single-version-id)
+          (u/resource-handle-xf batch-db tid)
+          (p/-matcher search-param batch-db modifier compiled-values)
+          (map svi/from-resource-handle)))
+
+  (-second-pass-filter [_ _ _])
+
+  (-index-values [_ _ _]
+    []))
+
+(defmethod special/special-search-param "near"
+  [index _]
+  (->SearchParamNear index "near" "special" "near"))

modules/db/src/blaze/db/impl/search_param/near/geo.clj

@@ -0,0 +1,34 @@
+(ns blaze.db.impl.search-param.near.geo)
+
+(set! *warn-on-reflection* true)
+
+(def ^:private ^:const earth-radius
+  "Earths mean radius in meters, see https://en.wikipedia.org/wiki/Earth_radius."
+  6371008.7714)
+
+(defn- sin2
+  "Sine of `angle` squared."
+  [angle]
+  (* (Math/sin angle) (Math/sin angle)))
+
+(defn haversine-distance
+  "Calculate the distance between two geographic coordinates (`location-1` and
+  `location-2`) using the Haversine formula, which simplifies by assuming a
+  spherical earth (error ≤ 0.5%). Returns distance in meters. See
+  https://en.wikipedia.org/wiki/Haversine_formula."
+  {:arglists '([location-1 location-2])}
+  [{lat-1 :latitude lon-1 :longitude} {lat-2 :latitude lon-2 :longitude}]
+  (let [delta-lat (Math/toRadians (- lat-2 lat-1))
+        delta-long (Math/toRadians (- lon-2 lon-1))
+        alpha (+ (sin2 (/ delta-lat 2))
+                 (* (Math/cos (Math/toRadians lat-1))
+                    (Math/cos (Math/toRadians lat-2))
+                    (sin2 (/ delta-long 2))))]
+    (* earth-radius (Math/asin (Math/sqrt alpha)) 2)))
+
+(defn near?
+  "Check if `location-1` and `location-2` are within `distance` meters of each
+  other using haversine-distance."
+  [location-1 location-2 distance]
+  (let [actual-dist (haversine-distance location-1 location-2)]
+    (<= actual-dist distance)))

modules/db/src/blaze/db/search_param_registry.clj

@@ -221,13 +221,18 @@
   {:type "special"
    :name "_has"})
 
+(def ^:private near-search-param
+  {:type "special"
+   :name "near"})
+
 (defn- add-special
   "Add special search params to `index`.
 
   See: https://www.hl7.org/fhir/search.html#special"
   [index]
   (-> (assoc-in index ["Resource" "_list"] (sc/search-param nil list-search-param))
-      (assoc-in ["Resource" "_has"] (sc/search-param index has-search-param))))
+      (assoc-in ["Resource" "_has"] (sc/search-param index has-search-param))
+      (assoc-in ["Location" "near"] (sc/search-param index near-search-param))))
 
 (defn- build-url-index* [index filter entries]
   (transduce

modules/db/test/blaze/db/api_test.clj

@@ -7461,7 +7461,35 @@
             (given (into [] xform (d/type-list db "Observation"))
               count := 1
               [0 :fhir/type] := :fhir/Observation
-              [0 :id] := "0")))))))
+              [0 :id] := "0"))))))
+
+  (testing "near search param"
+    (with-system-data [{:blaze.db/keys [node]} config]
+      [[[:put {:fhir/type :fhir/Location :id "0"
+               :position
+               {:fhir/type :fhir.Location/position          ; Berlin
+                :latitude #fhir/decimal 52.5200M :longitude #fhir/decimal 13.4050M}}]
+        [:put {:fhir/type :fhir/Location :id "1"
+               :position
+               {:fhir/type :fhir.Location/position          ; Cologne
+                :latitude #fhir/decimal 50.9334M :longitude #fhir/decimal 6.9619M}}]
+        [:put {:fhir/type :fhir/Location :id "2"
+               :position
+               {:fhir/type :fhir.Location/position          ; Jakarta
+                :latitude #fhir/decimal -6.2M :longitude #fhir/decimal 106.8167M}}]]]
+
+      (with-open-db [db node]
+        (doseq [target [node db]
+                [_ query id] [[:Berlin "52.5201|13.4051|15|m" "0"]
+                              [:Leipzig "51.3397|12.3731|150|km" "0"]
+                              [:Paris "48.8566|2.3522|403|km" "1"]
+                              [:Perth "-31.953512|115.857048|3014|km" "2"]]]
+          (let [matcher (d/compile-type-matcher target "Location" [["near" query]])
+                xform (d/matcher-transducer db matcher)]
+            (given (into [] xform (d/type-list db "Location"))
+              count := 1
+              [0 :fhir/type] := :fhir/Location
+              [0 :id] := id)))))))
 
 (deftest compile-system-matcher-test
   (with-system-data [{:blaze.db/keys [node]} config]

modules/db/test/blaze/db/impl/search_param/near/geo_spec.clj

@@ -0,0 +1,23 @@
+(ns blaze.db.impl.search-param.near.geo-spec
+  (:require
+   [clojure.spec.alpha :as s]))
+
+(s/def ::coordinate
+  number?)
+
+(s/def ::latitude
+  ::coordinate)
+
+(s/def ::longitude
+  ::coordinate)
+
+(s/def ::location
+  (s/keys :req-un [::latitude ::longitude]))
+
+(s/fdef haversine-distance
+  :args (s/cat :loc-1 ::location :loc-2 ::location)
+  :ret number?)
+
+(s/fdef near?
+  :args (s/cat :loc-1 ::location :loc-2 ::location :dist number?)
+  :ret boolean?)

modules/db/test/blaze/db/impl/search_param/near/geo_test.clj

@@ -0,0 +1,69 @@
+(ns blaze.db.impl.search-param.near.geo-test
+  (:require
+   [blaze.db.impl.search-param.near.geo :as geo]
+   [blaze.db.impl.search-param.near.geo-spec]
+   [clojure.test :refer [deftest is testing]]))
+
+;; Test data
+(def ^:private london
+  {:latitude 51.5074 :longitude -0.1278})
+
+(def ^:private paris
+  {:latitude 48.8566 :longitude 2.3522})
+
+(def ^:private jakarta
+  {:latitude -6.2M :longitude 106.8167M})
+
+(def ^:private perth
+  {:latitude -31.953512 :longitude 115.857048})
+
+(deftest haversine-distance-test
+  (testing "distance between identical locations"
+    (is (= 0.0 (geo/haversine-distance london london))))
+
+  (testing "distance between London and Paris"
+    ;; ~ 343km
+    (let [dist (geo/haversine-distance london paris)]
+      (is (<= dist 344000.0))
+      (is (>= dist 343000.0))))
+
+  (testing "distance between Jakarta and Perth"
+    ;; ~ 3013km
+    (let [dist (geo/haversine-distance jakarta perth)]
+      (is (<= dist 3014000.0))
+      (is (>= dist 3013000.0))))
+
+  (testing "distance between two points on equator 1 degree apart"
+    ;; ~ 111.195km
+    (let [dist (geo/haversine-distance
+                {:latitude 0.0 :longitude 0.0}
+                {:latitude 0.0 :longitude 1.0})]
+      (is (<= dist 111200.0))
+      (is (>= dist 111190.0))))
+
+  (testing "distance when crossing international date line (also 1 degree)"
+    ;; ~ 111.195km
+    (let [dist (geo/haversine-distance
+                {:latitude 0.0 :longitude 179.5}
+                {:latitude 0.0 :longitude -179.5})]
+      (is (<= dist 111200.0))
+      (is (>= dist 111190.0)))))
+
+(deftest near?-test
+  (testing "locations are within distance"
+    (is (geo/near? london paris 344000.0))
+    (is (geo/near? london paris 350000.0))
+    (is (geo/near? london paris 400000.0)))
+
+  (testing "locations are not within distance"
+    (is (not (geo/near? london paris 340000.0)))
+    (is (not (geo/near? london paris 300000.0))))
+
+  (testing "locations are roughly at distance"
+    (is (geo/near? london paris 343560.0)))
+
+  (testing "identical locations with zero distance"
+    (is (geo/near? london london 0.0)))
+
+  (testing "identical locations with non-zero distance"
+    (is (geo/near? london london 100.0))))