The Biocaml Library : Biocaml_wig.Transform

struct   

 let explode_key_value loc s =

  try

   let by_space =

    String.split_on_chars s ~on:[' '; '\n'; '\t'; '\r']

    |! List.filter ~f:((<>) "") in

   Ok (List.map by_space (fun s ->

    begin match String.split ~on:'=' s with

    | [ key; value ] -> (key, value)

    | anyother -> raise Not_found

    end))

  with

   Not_found -> Error (`cannot_parse_key_values (loc, s))

    

 let rec next ?(pedantic=true) ?(sharp_comments=true) p =

  let open Biocaml_transform.Line_oriented in

  let assoc_find ~missing l v =

   match List.Assoc.find l v with | Some v -> Ok v | None -> Error missing in

  let assoc_find_map ~missing ~wrong ~f l v =

   match List.Assoc.find l v with

   | Some v -> (try Ok (f v) with e -> Error wrong)

   | None -> Error missing in

  match next_line p with

  | Some "" ->

   if pedantic

   then output_error (`empty_line (current_position p))

   else next ~pedantic ~sharp_comments p

  | Some l when sharp_comments && String.is_prefix l ~prefix:"#" ->

   output_ok (`comment String.(sub l ~pos:1 ~len:(length l - 1)))

  | Some l when String.is_prefix l ~prefix:"fixedStep" ->

   let output_m =

    explode_key_value (current_position p)

     String.(chop_prefix_exn l ~prefix:"fixedStep")

    >>= fun assoc ->

    assoc_find assoc "chrom"

     ~missing:(`missing_chrom_value (current_position p, l))

    >>= fun chrom ->

    assoc_find_map assoc "start" 

     ~missing:(`missing_start_value (current_position p, l))

     ~f:Int.of_string ~wrong:(`wrong_start_value (current_position p, l))

    >>= fun start ->

    assoc_find_map assoc "step" 

     ~missing:(`missing_step_value (current_position p, l))

     ~f:Int.of_string ~wrong:(`wrong_step_value (current_position p, l))

    >>= fun step ->

    begin match List.Assoc.find assoc "span" with

    | None ->

     Ok (`fixed_step_state_change (chrom, start, step, None))

    | Some span ->

     begin match Option.try_with (fun () -> Int.of_string span) with

     | Some i ->

      Ok (`fixed_step_state_change (chrom, start, step, Some i))

     | None -> Error (`wrong_span_value (current_position p, span))

     end

    end

   in

   output_result output_m

  | Some l when String.is_prefix l ~prefix:"variableStep" ->

   let output_m =

    explode_key_value (current_position p)

     String.(chop_prefix_exn l ~prefix:"variableStep")

    >>= fun assoc ->

    assoc_find assoc "chrom"

     ~missing:(`missing_chrom_value (current_position p, l))

    >>= fun chrom ->

    begin match List.Assoc.find assoc "span" with

    | None -> return (`variable_step_state_change (chrom, None))

    | Some span ->

     begin match Option.try_with (fun () -> Int.of_string span) with

     | Some i -> return (`variable_step_state_change (chrom, Some i))

     | None -> fail (`wrong_span_value (current_position p, span))

     end

    end

   in

   output_result output_m

  | Some l ->

   let by_space =

    String.split_on_chars l ~on:[' '; '\n'; '\t'; '\r']

    |! List.filter ~f:((<>) "") in

   begin match by_space with

   | [ one_value ] ->

    (try output_ok (`fixed_step_value Float.(of_string one_value))

     with e -> output_error (`wrong_fixed_step_value (current_position p, l)))

   | [ fst_val; snd_val] ->

    (try output_ok (`variable_step_value (Int.of_string fst_val,

                      Float.of_string snd_val))

     with e -> output_error (`wrong_variable_step_value (current_position p, l)))

   | [ chr; b; e; v; ] ->

    (try output_ok (`bed_graph_value (chr,

                    Int.of_string b,

                    Int.of_string e,

                    Float.of_string v))

     with e -> output_error (`wrong_bed_graph_value (current_position p, l)))

   | l ->

    output_error (`unrecognizable_line (current_position p, l))

   end

  | None -> 

   `not_ready

    

    

 let string_to_t ?filename ?(tags=default_tags) () =

  let pedantic = List.mem tags `pedantic in

  let sharp_comments = List.mem tags `sharp_comments in

  let name = sprintf "wig_parser:%s" Option.(value ~default:"<>" filename) in

  let next = next ~pedantic ~sharp_comments in

  Biocaml_transform.Line_oriented.make_merge_error

   ~name ?filename ~next ()





 let t_to_string ?(tags=default_tags) () =

  let sharp_comments = List.mem tags `sharp_comments in

  let module PQ = Biocaml_transform.Printer_queue in

  let printer =

   PQ.make ~to_string:(function

   | `comment c -> if sharp_comments then sprintf "#%s\n" c else ""

   | `variable_step_state_change (chrom, span) ->

    sprintf "variableStep chrom=%s%s\n" chrom

     Option.(value_map ~default:"" span ~f:(sprintf " span=%d"))

   | `variable_step_value (pos, v) -> sprintf "%d %g\n" pos v

   | `fixed_step_state_change (chrom, start, step, span) ->

    sprintf "fixedStep chrom=%s start=%d step=%d%s\n" chrom start step 

     Option.(value_map ~default:"" span ~f:(sprintf " span=%d"))

   | `fixed_step_value v -> sprintf "%g\n" v

   | `bed_graph_value (chrom, start, stop, v) ->

    sprintf "%s %d %d %g\n" chrom start stop v) () in

  Biocaml_transform.make ~name:"wig_printer" ()

   ~feed:(fun r -> PQ.feed printer r)

   ~next:(fun stopped ->

    match (PQ.flush printer) with

    | "" -> if stopped then `end_of_stream else `not_ready

    | s -> `output s)



 let t_to_bed_graph () =

  let queue = Queue.create () in

  let current_state = ref None in

  Biocaml_transform.make ~name:"wig_to_variable_step" ()

   ~feed:(function

   | `comment _ -> ()

   | `bed_graph_value already_done ->

    Queue.enqueue queue (output_ok already_done)

   | `variable_step_state_change (chrom, span) ->

    current_state := Some (`variable (chrom, span))

   | `variable_step_value (pos, v) ->

    begin match !current_state with

    | Some (`variable (chrom, span)) ->

     let stop = pos + Option.(value ~default:1 span) - 1 in

     Queue.enqueue queue (output_ok (chrom, pos, stop, v))

    | other ->

     Queue.enqueue queue (output_error (`not_in_variable_step_state))

    end

   | `fixed_step_state_change (chrom, start, step, span) ->

    current_state := Some (`fixed (chrom, start, step , span, 0))

   | `fixed_step_value v ->

    begin match !current_state with

    | Some (`fixed (chrom, start, step, span, current)) ->

     let pos = start + (step * current) in

     let stop = pos + Option.(value ~default:1 span) - 1 in

     Queue.enqueue queue (output_ok (chrom, pos, stop, v));

     current_state := Some (`fixed (chrom, start, step , span, current + 1))

    | other ->

     Queue.enqueue queue (output_error (`not_in_fixed_step_state))

    end)

   ~next:(fun stopped ->

    match Queue.dequeue queue with

    | None -> if stopped then `end_of_stream else `not_ready

    | Some v -> v)

   

end