Source file bechamel_js.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
open Bechamel
type t =
{ x_label : string
; y_label : string
; series : (string, Desc.t * Dataset.t * KDE.t option * OLS.t) Hashtbl.t
}
let label_witness : string Json_encoding.encoding = Json_encoding.string
let witness ~compare : t Json_encoding.encoding =
let open Json_encoding in
let x_label = req "xLabel" label_witness in
let y_label = req "yLabel" label_witness in
let serie =
let name = req "name" string in
let dataset = req "dataset" Dataset.witness in
let kde = opt "kde" KDE.witness in
let ols = req "result" OLS.witness in
let desc = req "description" Desc.witness in
obj5 name desc dataset kde ols
in
let series = req "series" (list serie) in
conv
(fun t ->
let l =
Hashtbl.fold
(fun k (desc, dataset, kde, ols) a ->
(k, desc, dataset, kde, ols) :: a)
t.series []
in
( t.x_label
, t.y_label
, List.sort (fun (k0, _, _, _, _) (k1, _, _, _, _) -> compare k0 k1) l ))
(fun (x_label, y_label, l) ->
let series = Hashtbl.create (List.length l) in
List.iter
(fun (k, desc, dataset, kde, ols) ->
Hashtbl.add series k (desc, dataset, kde, ols))
l;
{ x_label; y_label; series })
(obj3 x_label y_label series)
let of_ols_results ~x_label ~y_label ols_results raws =
if not (Hashtbl.mem ols_results y_label) then
Rresult.R.error_msgf "y:%s does not exist in OLS results" y_label
else
let results = Hashtbl.find ols_results y_label in
let series = Hashtbl.create (Hashtbl.length results) in
try
Hashtbl.iter
(fun serie ols ->
let open Rresult.R in
let Benchmark.{ stats; lr = raws; kde = raws_kde } =
Hashtbl.find raws serie
in
let res =
Dataset.of_measurement_raws ~x_label ~y_label raws >>= fun raws ->
KDE.of_kde_raws ~label:y_label raws_kde >>= fun raws_kde ->
OLS.of_ols_result ~x_label ~y_label ols >>| fun ols ->
(stats, raws, raws_kde, ols)
in
match res with
| Ok (stats, raws, raws_kde, ols) ->
Hashtbl.add series serie (stats, raws, raws_kde, ols)
| Error _ as err -> Rresult.R.error_msg_to_invalid_arg err)
results;
Ok { x_label; y_label; series }
with Invalid_argument err -> Rresult.R.error_msg err
type value = [ `Null | `Bool of bool | `String of string | `Float of float ]
let flat json : Jsonm.lexeme list =
let rec arr acc k = function
| [] -> k (List.rev (`Ae :: acc))
| (#value as x) :: r -> arr (x :: acc) k r
| `A l :: r -> arr [ `As ] (fun l -> arr (List.rev_append l acc) k r) l
| `O l :: r -> obj [ `Os ] (fun l -> arr (List.rev_append l acc) k r) l
and obj acc k = function
| [] -> k (List.rev (`Oe :: acc))
| (n, x) :: r ->
base (fun v -> obj (List.rev_append v (`Name n :: acc)) k r) x
and base k = function
| `A l -> arr [ `As ] k l
| `O l -> obj [ `Os ] k l
| #value as x -> k [ x ]
in
base (fun l -> l) json
type buffer = bytes * int * int
type transmit = buffer -> buffer
type 'a or_error = ('a, [ `Msg of string ]) result
type 'a dst =
| Manual : transmit -> buffer dst
| Buffer : Buffer.t -> (Buffer.t -> unit or_error) dst
| Channel : out_channel -> (out_channel -> unit or_error) dst
let manual transmit = Manual transmit
let buffer ~chunk =
let buffer = Buffer.create chunk in
Buffer buffer
let channel filename =
let oc = open_out filename in
Channel oc
type raws = (string, Benchmark.t) Hashtbl.t
type ols_results = (string, (string, Analyze.OLS.t) Hashtbl.t) Hashtbl.t
let emit :
type a.
dst:a dst
-> a
-> ?compare:(string -> string -> int)
-> x_label:string
-> y_label:string
-> ols_results * raws
-> unit or_error =
fun ~dst a ?compare:(compare_label = String.compare) ~x_label ~y_label
(ols_results, raw_results) ->
let to_dst : type a. a dst -> Jsonm.dst = function
| Manual _ -> `Manual
| Buffer buffer -> `Buffer buffer
| Channel oc -> `Channel oc
in
let encoder = Jsonm.encoder ~minify:true (to_dst dst) in
let buf, off, len =
match dst with
| Manual _ ->
let buf, off, len = a in
(ref buf, ref off, ref len)
| Buffer _ -> (ref Bytes.empty, ref 0, ref 0)
| Channel _ -> (ref Bytes.empty, ref 0, ref 0)
in
let go json =
let flat = flat json in
List.iter
(fun lexeme ->
match Jsonm.encode encoder (`Lexeme lexeme) with
| `Ok -> ()
| `Partial -> (
match dst with
| Manual transmit ->
let buf', off', len' =
transmit (!buf, !off, !len - Jsonm.Manual.dst_rem encoder)
in
buf := buf';
off := off';
len := len';
Jsonm.Manual.dst encoder buf' off' len'
| Buffer _ -> ()
| Channel _ -> ()))
flat;
let rec go : type a. a dst -> a -> unit or_error =
fun dst a ->
match (Jsonm.encode encoder `End, dst) with
| `Ok, Buffer buf -> a buf
| `Ok, Channel oc -> a oc
| `Ok, Manual _ -> Ok ()
| `Partial, Manual transmit ->
let buf', off', len' =
transmit (!buf, !off, !len - Jsonm.Manual.dst_rem encoder)
in
buf := buf';
off := off';
len := len';
Jsonm.Manual.dst encoder buf' off' len';
go dst a
| `Partial, Buffer _ -> assert false
| `Partial, Channel _ -> assert false
in
go dst a
in
let open Rresult.R in
of_ols_results ~x_label ~y_label ols_results raw_results
>>| Json_encoding.construct (witness ~compare:compare_label)
>>= go