Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
tree: b4eb282066
Fetching contributors…

Cannot retrieve contributors at this time

1245 lines (1060 sloc) 37.727 kB
(*s: treemap.ml *)
(*s: Facebook copyright *)
(* Yoann Padioleau
*
* Copyright (C) 2010 Facebook
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* version 2.1 as published by the Free Software Foundation, with the
* special exception on linking described in file license.txt.
*
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file
* license.txt for more details.
*)
(*e: Facebook copyright *)
open Common
module F = Figures
open Figures
module Color = Simple_color
(*****************************************************************************)
(* Prelude *)
(*****************************************************************************)
(*****************************************************************************)
(* Types *)
(*****************************************************************************)
(*s: type treemap *)
type ('dir, 'file) treemap =
(treemap_rect * 'dir, treemap_rect * 'file) Common.tree
and treemap_rect = {
size : int;
color : Simple_color.color;
label: string;
}
(*e: type treemap *)
(* with tarzan *)
(*s: type algorithm *)
type algorithm =
| Classic
| Squarified
| SquarifiedNoSort
| Ordered of pivot
and pivot =
| PivotBySize
| PivotByMiddle
(*e: type algorithm *)
(*s: variable algos *)
let algos = [Classic; Squarified; SquarifiedNoSort;
Ordered PivotBySize; Ordered PivotByMiddle]
(*e: variable algos *)
(*s: type screen_dim *)
type screen_dim = {
(* total width/height *)
w: int;
h: int;
(* the viewport *)
w_view: int;
h_view: int;
(* extra information *)
h_status: int;
w_legend: int;
}
(*e: type screen_dim *)
(*s: type rectangle1 *)
(* The array has 2 elements, for x, y. I use an array because that's how
* the seminal algorithm on treemap was written. It allows to pass
* as an int the current split and do x.(axis_split) and do a 1-axis_split
* in recursive calls to go from a x-split to a y-split.
*
* A rectangle is represented by 2 variables called P and Q in the seminal
* algorithm.
*)
type rectangle1 =
float array (* lower left coord, P *) *
float array (* upper right coord, Q *)
(*e: type rectangle1 *)
(* A cleaner rectangle type, not tied to the seminal paper design decisions *)
(* Now that my treemap visualizer uses a minimap, it does not completely
* use the full width.
* old: was 16/9 = 1.777777
*)
let xy_ratio = 1.6
(* The dimentions are in a [0.0-1.0] range for y and [0.0-xyratio] for x,
* where xyratio is used to cope with most 16/9 screens.
*)
let rect_ortho =
{ p = {x = 0.0; y = 0.0; }; q = { x = xy_ratio; y = 1.0} }
(* the dimentions are in a [0.0-1.0] range *)
type treemap_rendering = treemap_rectangle list
and treemap_rectangle = {
tr_rect: rectangle;
tr_color: int (* Simple_color.color *);
tr_label: string;
tr_depth: int;
tr_is_node: bool;
}
(* with tarzan *)
(*s: type layout_func *)
type ('a, 'b) layout_func =
(float * ('a, 'b) treemap) list ->
int ->
rectangle ->
(float * ('a, 'b) treemap * rectangle) list
(*e: type layout_func *)
(*****************************************************************************)
(* Accessors *)
(*****************************************************************************)
(*s: function treemap accessors *)
let color_of_treemap_node x =
match x with
| Node (({color = c; _}, _), _) -> c
| Leaf (({color = c; _}, _)) -> c
let size_of_treemap_node x =
match x with
| Node (({size = s; _}, _), _) -> s
| Leaf (({size = s; _}, _)) -> s
(*e: function treemap accessors *)
(*s: function algorithm accessors *)
let algo_of_s algo =
match algo with
| "classic" -> Classic
| "squarified" -> Squarified
| "squarified_no_sort" -> SquarifiedNoSort
| "ordered" -> Ordered PivotBySize
| "ordered_by_size" -> Ordered PivotBySize
| "ordered_by_middle" -> Ordered PivotByMiddle
| "default" -> Ordered PivotByMiddle
| _ -> failwith "not a valid algorithm"
let s_of_algo algo =
match algo with
| Classic -> "classic"
| Squarified -> "squarified"
| SquarifiedNoSort -> "squarified_no_sort"
| Ordered PivotBySize -> "ordered_by_size"
| Ordered PivotByMiddle -> "ordered_by_middle"
(*e: function algorithm accessors *)
(*****************************************************************************)
(* Treemap Helpers *)
(*****************************************************************************)
(*s: function treemap_of_tree *)
let treemap_of_tree2
~size_of_leaf
~color_of_leaf
?(label_of_file=(fun _ -> ""))
?(label_of_dir=(fun _ -> ""))
tree =
let rec aux tree =
match tree with
| Node (nodeinfo, xs) ->
let sizeme = ref 0 in
let child = List.map (fun x ->
let (res, size) = aux x in
sizeme := !sizeme + size;
res
) xs
in
(* old:
* let children = xs +> List.map aux in
* let child = children +> List.map fst in
* let sizes = children +> List.map snd in
* let sizeme = Common.sum sizes in
*)
let sizeme = !sizeme in
Node((
{
size = sizeme;
color = Color.black; (* TODO ? nodes have colors ? *)
label = label_of_dir nodeinfo;
}, nodeinfo),
child), sizeme
| Leaf leaf ->
let sizeme = size_of_leaf leaf in
let nodeinfo = leaf in
Leaf((
{
size = sizeme;
color = color_of_leaf leaf;
label = label_of_file leaf;
}, nodeinfo)
), sizeme
in
let (tree, _size) = aux tree in
tree
(*e: function treemap_of_tree *)
let treemap_of_tree ~size_of_leaf ~color_of_leaf
?label_of_file ?label_of_dir tree =
Common.profile_code "Treemap.treemap_of_tree" (fun () ->
treemap_of_tree2 ~size_of_leaf ~color_of_leaf
?label_of_file ?label_of_dir tree)
(*****************************************************************************)
(* Treemap algorithms *)
(*****************************************************************************)
(*---------------------------------------------------------------------------*)
(* basic algorithm *)
(*---------------------------------------------------------------------------*)
(* display_treemap and display_treemap_generic are now in
* in treemap_graphics.ml, because of Graphics dependency.
*)
(*---------------------------------------------------------------------------*)
(* slice and dice algorithm layout *)
(*---------------------------------------------------------------------------*)
(*s: layout slice and dice *)
let (slice_and_dicing_layout: ('a, 'b) layout_func) =
fun children depth rect ->
let p = [| rect.p.x; rect.p.y |] in
let q = [| rect.q.x; rect.q.y |] in
let axis_split = (depth + 1) mod 2 in
let stotal = children +> List.map fst +> Common.sum_float in
let width = q.(axis_split) -. p.(axis_split) in
children +> List.map (fun (size, child) ->
q.(axis_split) <-
p.(axis_split) +.
((size) /. stotal) *. width;
let rect_here = {
p = { x = p.(0); y = p.(1); };
q = { x = q.(0); y = q.(1); }
}
in
p.(axis_split) <- q.(axis_split);
size, child, rect_here
)
(*e: layout slice and dice *)
(*---------------------------------------------------------------------------*)
(* squarified algorithm *)
(*---------------------------------------------------------------------------*)
(*s: squarified examples *)
(* ref: www.win.tue.nl/~vanwijk/stm.pdf
*
* In the following I use some of the examples in the paper so you'll need
* the paper to follow what I say.
*)
(*
* A few examples.
*
* the total sum in squarified_list_area_ex is 24, just like the area
* of rect_orig below. This simplifies discussions.
*
* I've added the string later as we want squarify to also return
* information related to the node with its size (that is the full treemap
* node, with its descendant)
*)
let squarified_list_area_ex =
[6; 6; 4; 3; 2; 2; 1] +> List.map (fun x -> float_of_int x, spf "info: %d" x)
(* normally our algorithm should do things proportionnally to the size
* of the aready. It should not matter that the total sum of area is
* equal to the size of the rectangle. Indeed later we will always do
* things in an ortho plan, that is with a rectangle 0x0 to 1x1.
*)
let squarified_list_area_ex2 =
squarified_list_area_ex +> List.map (fun (x, info) -> x *. 2.0, info)
let dim_rect_orig =
{ p = {x = 0.0; y = 0.0; }; q = { x = 6.0; y = 4.0} }
(*e: squarified examples *)
(*s: type split *)
type split =
(* Spread one next to the other, e.g. | | | | | |
* The split lines will be vertical, but the rectangles
* would be spreaded horizontally. In the paper they call that horizontal
* Split but I prefer Spread, because the split lines are actually verticals.
*)
| SpreadHorizontally
(* Spread one on top of the other eg _
* _
* _
*)
| SpreadVertically
(*e: type split *)
(*s: function ratio_rect_dim *)
(* we want the ratio to be a close to 1 as possible (that is to be a square) *)
let ratio_rect_dim (w,h) =
let res = max (w /. h) (h /. w) in
(* assert (res >= 1.0); *)
res
let _ = assert (ratio_rect_dim (6.0, 4.0) = 1.5)
let _ = assert (ratio_rect_dim (4.0, 6.0) = 1.5)
(*e: function ratio_rect_dim *)
(*s: function worst *)
(* On the running example, at the first step we want to add the rect of
* size 6 on the left, alone, and its aspect ratio will be 8/3.
* Indeed its height is fixed (4) and so his width is
* whatever that must lead to an area of 6, that is 6/4 (1.5)
* which leads then to an aspect ratio of 4 vs 1.5 = 4 / 1.5 = 8/3.
* If we add 2 rect of size 6, then their aspect ratio is 1.5 which is
* better
*)
let worst elems_in_row size_side_row =
let s = Common.sum_float elems_in_row in
let rplus = Common.maximum elems_in_row in
let rminus = Common.minimum elems_in_row in
(* cf formula in paper *)
max ((Common.square size_side_row *. rplus) /. Common.square s)
(Common.square s /. (Common.square size_side_row *. rminus))
let _ = assert
(worst [6.0] 4.0 = 8.0 /. 3.0) (* 2.66667 *)
let _ = assert
(worst [6.0;6.0] 4.0 = 3.0 /. 2.0) (* 1.5, which is close to 1 so better *)
let _ = assert
(worst [6.0;6.0;4.0] 4.0 = 4.0) (* 4.0, we regress *)
(*e: function worst *)
(*s: function layout *)
(* We are given a fixed row which contains a set of elems that we have
* to spread unoformly, just like in the original algorithm.
*)
let layout row rect =
let p = [| rect.p.x; rect.p.y |] in
let q = [| rect.q.x; rect.q.y |] in
let children = row in
let stotal = children +> List.map fst +> Common.sum_float in
let children = children +> List.map (fun (size, info) ->
size /. stotal (* percentage *),
size,
info
)
in
let res = ref [] in
let spread =
if rect_width rect >= rect_height rect
then SpreadHorizontally
else SpreadVertically
in
let axis_split =
match spread with
| SpreadHorizontally -> 0
| SpreadVertically -> 1
in
let width = q.(axis_split) -. p.(axis_split) in
children +> List.iter (fun (percent_child, size_child, info) ->
q.(axis_split) <-
p.(axis_split) +.
percent_child *. width;
let rect_here = {
p = { x = p.(0); y = p.(1); };
q = { x = q.(0); y = q.(1); }
}
in
Common.push2 (size_child, info, rect_here) res;
p.(axis_split) <- q.(axis_split);
);
!res
(*e: function layout *)
(* the main algorithmic part of squarifying *)
(*s: function squarify_orig *)
let rec (squarify_orig:
?verbose:bool ->
(float * 'a) list -> (float * 'a) list -> rectangle ->
(float * 'a * rectangle) list
) =
fun ?(verbose=false) children current_row rect ->
(* does not work well because of float approximation.
* assert(Common.sum_float (children ++ current_row) = rect_area rect);
*)
let (p, q) = rect.p, rect.q in
let floats xs = List.map fst xs in
(* First heuristic in the squarified paper *)
let spread =
if rect_width rect >= rect_height rect (* e.g. 6 x 4 rectangle *)
then SpreadHorizontally
else SpreadVertically
in
(* We now know what kind of row we want. If spread horizontally then
* we will have a row on the left to fill and the size of the side of
* this row is known and is the height of the rectangle (in our ex 4).
* In the paper they call this variable 'width' but it's misleading.
* Note that because we are in Horizontal mode, inside this left row,
* things will be spreaded this time vertically.
*)
let size_side_row =
match spread with
| SpreadHorizontally -> rect_height rect
| SpreadVertically -> rect_width rect
in
match children with
| c::cs ->
if null current_row ||
(worst (floats (current_row ++ [c])) size_side_row)
<=
(worst (floats current_row) size_side_row)
then
(* not yet optimal row, let's recurse *)
squarify_orig cs (current_row ++ [c]) rect
else begin
(* optimal layout for the left row. We can fix it. *)
let srow = Common.sum_float (floats current_row) in
let stotal = Common.sum_float (floats (current_row ++ children)) in
let portion_for_row = srow /. stotal in
let row_rect, remaining_rect =
match spread with
| SpreadHorizontally ->
let middle_x =
(q.x -. p.x) *. portion_for_row
+. p.x
in
{
p = p;
q = { x = middle_x; y = q.y };
},
{
p = { x = middle_x; y = p.y};
q = q;
}
| SpreadVertically ->
let middle_y =
(q.y -. p.y) *. portion_for_row
+. p.y in
{
p = p;
q = { x = q.x; y = middle_y;};
},
{
p = { x = p.x; y = middle_y};
q = q;
}
in
if verbose then begin
pr2 "layoutrow:";
pr2_gen current_row;
pr2 "row rect";
pr2 (s_of_rectangle row_rect);
end;
let rects_row = layout current_row row_rect in
let rects_remain = squarify_orig children [] remaining_rect in
rects_row ++ rects_remain
end
| [] ->
if verbose then begin
pr2 "layoutrow:";
pr2_gen current_row;
pr2 "row rect";
pr2 (s_of_rectangle rect);
end;
layout current_row rect
(*e: function squarify_orig *)
(*s: function squarify *)
let squarify children rect =
(* squarify_orig assume the sum of children = area rect *)
let area = rect_area rect in
let total = Common.sum_float (List.map fst children) in
let children' = children +> List.map (fun (x, info) ->
(x /. total) *. area,
info
)
in
squarify_orig children' [] rect
(*e: function squarify *)
(*s: function test_squarify *)
let test_squarify () =
pr2_gen (worst [6.0] 4.0);
pr2_gen (worst [6.0;6.0] 4.0);
pr2_gen (worst [6.0;6.0;4.0] 4.0);
pr2_xxxxxxxxxxxxxxxxx ();
squarify squarified_list_area_ex dim_rect_orig +> ignore;
pr2_xxxxxxxxxxxxxxxxx ();
squarify squarified_list_area_ex2 rect_ortho +> ignore;
()
(*e: function test_squarify *)
(*s: layout squarify *)
let (squarify_layout: ('a, 'b) layout_func) =
fun children _depth rect ->
let children' = children +> Common.sort_by_key_highfirst in
squarify children' rect
let (squarify_layout_no_sort_size: ('a, 'b) layout_func) =
fun children _depth rect ->
squarify children rect
(*e: layout squarify *)
(*---------------------------------------------------------------------------*)
(* Ordered squarified algorithm *)
(*---------------------------------------------------------------------------*)
(*s: ordered examples *)
(* ref:
*)
let children_ex_ordered_2001 = [
1; 5; 3; 4; 5; 1;
10; 1; 1; 2; 7; 3;
5; 2; 10; 1; 2; 1;
1; 2;
]
(*e: ordered examples *)
(*s: type pivotized *)
type 'a pivotized = {
left: 'a;
right: 'a;
pivot: 'a; (* this one should be singleton and the other a list *)
above_pivot: 'a;
}
(*e: type pivotized *)
(*s: function compute_rects_pivotized *)
let compute_rects_pivotized childs_pivotized rect spread =
let (p, q) = rect.p, rect.q in
let x = childs_pivotized in
let size = {
left = Common.sum_float (Common.map fst x.left);
right = Common.sum_float (Common.map fst x.right);
pivot = Common.sum_float (Common.map fst x.pivot);
above_pivot = Common.sum_float (Common.map fst x.above_pivot);
}
in
let total_size = size.left +. size.right +. size.pivot +. size.above_pivot in
let portion_for_left = size.left /. total_size in
let portion_for_right = size.right /. total_size in
let portion_for_pivot_vs_above =
(size.pivot ) /. (size.pivot +. size.above_pivot)
in
(* computing the rectangle of the left and right is easy as the
* height is fixed (when we spread horizontally)
*)
match spread with
| SpreadHorizontally ->
(* TODO do something that adapt to rect ? lourd que rect
* commence pas 0,0, ca fait faire des calculs en plus. *)
let middle_x1 =
p.x +. ((rect_width rect) *. portion_for_left)
in
let middle_x2 =
q.x -. ((rect_width rect) *. portion_for_right)
in
let middle_y =
p.y +. ((rect_height rect) *. portion_for_pivot_vs_above)
in
{ left = {
p = p;
q = { x = middle_x1; y = q.y } };
right = {
p = { x = middle_x2; y = p.y };
q = q; };
pivot = {
p = { x = middle_x1; y = p.y};
q = { x = middle_x2; y = middle_y}; };
above_pivot = {
p = { x = middle_x1; y = middle_y };
q = { x = middle_x2; y = q.y; } };
}
| SpreadVertically ->
(* just the reverse of previous code, x become y and vice versa *)
let middle_y1 =
p.y +. ((rect_height rect) *. portion_for_left)
in
let middle_y2 =
q.y -. ((rect_height rect) *. portion_for_right)
in
let middle_x =
p.x +. ((rect_width rect) *. portion_for_pivot_vs_above)
in
{ left = {
p = p;
q = { x = q.x; y = middle_y1; } };
right = {
p = { x = p.x; y = middle_y2; };
q = q; };
pivot = {
p = { x = p.x; y = middle_y1; };
q = { x = middle_x; y = middle_y2; } };
above_pivot = {
p = { x = middle_x; y = middle_y1; };
q = { x = q.x; y = middle_y2; } }
}
(*e: function compute_rects_pivotized *)
(*s: function balayer_right_wrong *)
let rec balayer_right_wrong xs =
match xs with
| [] -> []
| x::xs ->
let first =
[], x::xs
in
let last =
x::xs, []
in
let rest = balayer_right_wrong xs in
let rest' = rest +> List.map (fun (start, theend) -> x::start, theend) in
[first] ++ rest' ++ [last]
let balayer_right xs =
let n = List.length xs in
let res = ref [] in
for i = 0 to n do
Common.push2 (take i xs, drop i xs) res;
done;
List.rev !res
let _ = assert (balayer_right [1;2;3;2] =
[
[], [1;2;3;2];
[1], [2;3;2];
[1;2], [3;2];
[1;2;3], [2];
[1;2;3;2], [];
])
(*e: function balayer_right_wrong *)
(*s: function orderify_children *)
let rec orderify_children ?(pivotf=PivotBySize) xs rect =
let rec aux xs rect =
match xs with
| [] -> []
| [size, x] ->
[size, x, rect]
| x::y::ys ->
let left, pivot, right =
match pivotf with
| PivotBySize ->
let pivot_max = Common.maximum (xs +> List.map fst) in
Common.split_when
(fun x -> fst x = pivot_max) xs
| PivotByMiddle ->
let nmiddle = List.length xs / 2 in
let start, thend = Common.splitAt nmiddle xs in
start, List.hd thend, List.tl thend
in
let spread =
if rect_width rect >= rect_height rect (* e.g. 6 x 4 rectangle *)
then SpreadHorizontally
else SpreadVertically
in
let right_combinations = balayer_right right in
let scores_and_rects =
right_combinations +> List.map (fun (above_pivot, right) ->
let childs_pivotized =
{ left = left;
pivot = [pivot];
right = right;
above_pivot = above_pivot;
}
in
let rects = compute_rects_pivotized childs_pivotized rect spread in
ratio_rect_dim (rect_width rects.pivot, rect_height rects.pivot),
(rects,
childs_pivotized)
)
in
let best = Common.sort_by_key_lowfirst scores_and_rects +> List.hd in
let (_score, (rects, childs_pivotized)) = best in
(* pr2_gen rects; *)
aux childs_pivotized.left rects.left ++
aux childs_pivotized.pivot rects.pivot ++
aux childs_pivotized.above_pivot rects.above_pivot ++
aux childs_pivotized.right rects.right ++
[]
in
aux xs rect
(*e: function orderify_children *)
(*s: function test_orderify *)
let test_orderify () =
let xs = children_ex_ordered_2001 +> List.map float_of_int in
let rect = rect_ortho in
let fake_treemap = () in
let children = xs +> List.map (fun size -> size, fake_treemap) in
let layout = orderify_children children rect in
pr2_gen layout
(*e: function test_orderify *)
(*s: layout ordered *)
let (ordered_layout: ?pivotf:pivot -> ('a, 'b) layout_func) =
fun ?pivotf children depth rect ->
orderify_children ?pivotf children rect
(*e: layout ordered *)
(*---------------------------------------------------------------------------*)
(* cushion algorithm *)
(*---------------------------------------------------------------------------*)
(* TODO *)
(*---------------------------------------------------------------------------*)
(* frontend *)
(*---------------------------------------------------------------------------*)
let layoutf_of_algo algo =
match algo with
| Classic -> slice_and_dicing_layout
| Squarified -> squarify_layout
| SquarifiedNoSort -> squarify_layout_no_sort_size
| Ordered pivotf -> ordered_layout ~pivotf
let render_treemap_algo2 = fun ?(algo=Classic) ?(big_borders=false) treemap ->
let flayout = layoutf_of_algo algo in
let treemap_rects = ref [] in
let rec aux_treemap root rect ~depth =
let (p,q) = rect.p, rect.q in
if not (valid_rect rect)
then () (* TODO ? warning ? *)
else
(match root with
| Leaf (tnode, fileinfo) ->
let color = color_of_treemap_node root in
Common.push2 {
tr_rect = rect;
tr_color = color;
tr_label = tnode.label;
tr_depth = depth;
tr_is_node = false;
} treemap_rects;
| Node (mode, children) ->
(* let's draw some borders. Far better to see the structure. *)
Common.push2 {
tr_rect = rect;
tr_color = Color.black;
tr_label = (fst mode).label;
tr_depth = depth;
tr_is_node = true;
} treemap_rects;
(* does not work, weird *)
let border =
if not big_borders then
match depth with
| 1 -> 0.0
| 2 -> 0.003
| 3 -> 0.001
| 4 -> 0.0005
| 5 -> 0.0002
| _ -> 0.0
else
match depth with
| 1 -> 0.0
| 2 -> 0.003
| 3 -> 0.0015
| 4 -> 0.0010
| 5 -> 0.0008
| 6 -> 0.0005
| _ -> 0.0002
in
let p = {
x = p.x +. border;
y = p.y +. border;
}
in
let q = {
x = q.x -. border;
y = q.y -. border;
}
in
(* todo? can overflow ... check still inside previous rect *)
let rect = { p = p; q = q } in
let children' =
children +> List.map (fun child ->
float_of_int (size_of_treemap_node child),
child
)
in
let rects_with_info =
(* generic call *)
flayout children' depth rect
in
(* less: assert rects_with_info are inside rect ? *)
rects_with_info +> List.iter (fun (x, child, rect) ->
aux_treemap child rect ~depth:(depth + 1)
);
)
in
aux_treemap treemap rect_ortho ~depth:1;
List.rev !treemap_rects
let render_treemap_algo ?algo ?big_borders x =
Common.profile_code "Treemap.render_treemap" (fun () ->
render_treemap_algo2 ?algo ?big_borders x)
(*****************************************************************************)
(* Main display function *)
(*****************************************************************************)
(* now in treemap_graphics.ml *)
(*****************************************************************************)
(* Source converters *)
(*****************************************************************************)
type directory_sort =
| NoSort
| SortDirThenFiles
| SortDirAndFiles
| SortDirAndFilesCaseInsensitive
let follow_symlinks = ref false
(*s: function tree_of_dir *)
let tree_of_dir2
?(filter_file=(fun _ -> true))
?(filter_dir=(fun _ -> true))
?(sort=SortDirAndFilesCaseInsensitive)
~file_hook
dir
=
let rec aux dir =
let subdirs =
Common.readdir_to_dir_list dir +> List.map (Filename.concat dir) in
let files =
Common.readdir_to_file_list dir +> List.map (Filename.concat dir) in
let subdirs =
subdirs +> Common.map_filter (fun dir ->
if filter_dir dir
then Some (dir, aux dir)
else None
)
in
let files =
files +> Common.map_filter (fun file ->
if filter_file file
then Some (file, (Leaf (file, file_hook file)))
else None
)
in
let agglomerated =
match sort with
| NoSort -> subdirs ++ files
| SortDirThenFiles ->
Common.sort_by_key_lowfirst subdirs ++
Common.sort_by_key_lowfirst files
| SortDirAndFiles ->
Common.sort_by_key_lowfirst (subdirs ++ files)
| SortDirAndFilesCaseInsensitive ->
let xs = (subdirs ++ files) +> List.map (fun (s, x) ->
lowercase s, x
)
in
Common.sort_by_key_lowfirst xs
in
let children = List.map snd agglomerated in
Node(dir, children)
in
aux dir
(*e: function tree_of_dir *)
(* specialized version *)
let tree_of_dir3
?(filter_file=(fun _ -> true))
?(filter_dir=(fun _ -> true))
?(sort=SortDirAndFilesCaseInsensitive)
~file_hook
dir
=
if sort <> SortDirAndFilesCaseInsensitive
then failwith "Only SortDirAndFilesCaseInsensitive is handled";
let rec aux dir =
let children = Sys.readdir dir in
let children = Array.map (fun x -> Common.lowercase x, x) children in
Array.fast_sort (fun (a1, b1) (a2, b2) -> compare a1 a2) children;
let res = ref [] in
children +> Array.iter (fun (_, f) ->
let full = Filename.concat dir f in
let stat = Common.unix_lstat_eff full in
match stat.Unix.st_kind with
| Unix.S_REG ->
if filter_file full
then Common.push2 (Leaf (full, file_hook full)) res
| Unix.S_DIR ->
if filter_dir full
then Common.push2 (aux full) res
| Unix.S_LNK ->
if !follow_symlinks then
(try
(match (Unix.stat full).Unix.st_kind with
| Unix.S_REG ->
if filter_file full
then Common.push2 (Leaf (full, file_hook full)) res
| Unix.S_DIR ->
if filter_dir full
then Common.push2 (aux full) res
| _ -> ()
)
with Unix.Unix_error _ ->
pr2 (spf "PB stat link at %s" full);
)
else ()
| _ -> ()
);
Node(dir, List.rev !res)
in
aux dir
let tree_of_dir ?filter_file ?filter_dir ?sort ~file_hook a =
Common.profile_code "Treemap.tree_of_dir" (fun () ->
tree_of_dir3 ?filter_file ?filter_dir ?sort ~file_hook a)
let rec tree_of_dir_or_file
?filter_file
?filter_dir
?sort
~file_hook
path
=
if Common.is_directory path
then
tree_of_dir ?filter_file ?filter_dir ?sort ~file_hook path
else Leaf (path, file_hook path)
(* Some nodes may have stuff in common that we should factor.
* todo: factorize code with Common.tree_of_files
*)
let add_intermediate_nodes root_path nodes =
let root = chop_dirsymbol root_path in
if not (Common.is_absolute root)
then failwith ("must pass absolute path, not: " ^ root);
let root = Common.split "/" root in
(* extract dirs and file from file, e.g. ["home";"pad"], "__flib.php", path *)
let xs = nodes +> List.map (fun x ->
match x with
| Leaf (file, _) -> Common.dirs_and_base_of_file file, x
| Node (dir, _) -> Common.dirs_and_base_of_file dir, x
)
in
(* remove the root part *)
let xs = xs +> List.map (fun ((dirs, base), node) ->
let n = List.length root in
let (root', rest) =
Common.take n dirs,
Common.drop n dirs
in
assert(root' =*= root);
(rest, base), node
)
in
(* now ready to build the tree recursively *)
let rec aux current_root xs =
let files_here, rest =
xs +> List.partition (fun ((dirs, base), _) -> null dirs)
in
let groups =
rest +> group_by_mapped_key (fun ((dirs, base),_) ->
(* would be a file if null dirs *)
assert(not (null dirs));
List.hd dirs
) in
let nodes =
groups +> List.map (fun (k, xs) ->
let xs' = xs +> List.map (fun ((dirs, base), node) ->
(List.tl dirs, base), node
)
in
let dirname = Filename.concat current_root k in
Node (dirname, aux dirname xs')
)
in
let leaves = files_here +> List.map (fun ((_dir, base), node) ->
node
) in
nodes ++ leaves
in
aux root_path xs
let tree_of_dirs_or_files2
?filter_file
?filter_dir
?sort
~file_hook
paths
=
match paths with
| [] -> failwith "tree_of_dirs_or_files: empty list"
| [x] ->
tree_of_dir_or_file ?filter_file ?filter_dir ?sort ~file_hook x
| xs ->
let nodes =
xs +> List.map (fun x ->
tree_of_dir_or_file ?filter_file ?filter_dir ?sort ~file_hook x
)
in
let root = Common.common_prefix_of_files_or_dirs xs in
let nodes = add_intermediate_nodes root nodes in
Node (root, nodes)
let tree_of_dirs_or_files ?filter_file ?filter_dir ?sort ~file_hook x =
Common.profile_code "Treemap.tree_of_dirs_or_files" (fun () ->
tree_of_dirs_or_files2 ?filter_file ?filter_dir ?sort ~file_hook x
)
(* Some software, especially java have often a long chain
* of single directory, like org/eclipse/...
* which then introduce extra depth in the treemap which leads
* to overlapping labels and very small labels for the actual
* childrens. This function removes those intermediate singleton
* sub directories.
*)
let rec remove_singleton_subdirs tree =
match tree with
| Leaf x -> tree
| Node (x, [Node (y, ys)]) ->
(* todo? merge x and y ? *)
remove_singleton_subdirs (Node (x, ys))
| Node (x, ys) ->
Node (x, List.map remove_singleton_subdirs ys)
(*****************************************************************************)
(* Testing *)
(*****************************************************************************)
(*s: concrete rectangles example *)
(* src: python treemap.py
* lower, upper, rgb
*)
let treemap_rectangles_ex = [
[0.0, 0.0], [1.0, 1.0], (0.17778372236496054, 0.75183542244426871, 0.77892130219255096);
[0.0, 0.0], [0.27659574468085107, 1.0], (0.54757582213226441, 0.945582381819014, 0.26427761420055917);
[0.0, 0.0], [0.27659574468085107, 0.38461538461538464], (0.71931501307446211, 0.95905644995588246, 0.28633110533256656);
[0.0, 0.38461538461538464], [0.27659574468085107, 1.0], (0.29508972521695809, 0.35521829137775873, 0.46070336222733932);
[0.0, 0.38461538461538464], [0.10372340425531915, 1.0], (0.51529552034735771, 0.53725734991812635, 0.22430742368105949);
[0.10372340425531915, 0.38461538461538464], [0.27659574468085107, 1.0], (0.43861905319415506, 0.16281118710897469, 0.60250203640050937);
[0.27659574468085107, 0.0], [0.36170212765957449, 1.0], (0.3743827201120038, 0.07170428778373239, 0.09006244270341246);
[0.36170212765957449, 0.0], [0.8936170212765957, 1.0], (0.39117531981521536, 0.16579633978705666, 0.63690597944460248);
[0.36170212765957449, 0.0], [0.8936170212765957, 0.20000000000000001], (0.34982099039431447, 0.54618822154424429, 0.19282777912183513);
[0.36170212765957449, 0.20000000000000001], [0.8936170212765957, 0.28000000000000003], (0.14570785913376116, 0.88033416430670342, 0.51911403487550056);
[0.36170212765957449, 0.28000000000000003], [0.8936170212765957, 0.76000000000000001], (0.79691567717907263, 0.3307536109585284, 0.95607296382731199);
[0.36170212765957449, 0.28000000000000003], [0.45035460992907805, 0.76000000000000001], (0.7038680786604008, 0.12714028216462059, 0.17131117338368551);
[0.45035460992907805, 0.28000000000000003], [0.58333333333333337, 0.76000000000000001], (0.036414279679915174, 0.94100891978030599, 0.017007582879843386);
[0.58333333333333337, 0.28000000000000003], [0.8936170212765957, 0.76000000000000001], (0.63659306932350279, 0.25303150185397794, 0.81066700006123815);
[0.58333333333333337, 0.28000000000000003], [0.8936170212765957, 0.48571428571428577], (0.38368601825375115, 0.083946154840038423, 0.048274714595522017);
[0.58333333333333337, 0.48571428571428577], [0.8936170212765957, 0.62285714285714289], (0.70513207607633877, 0.95785105976069096, 0.87735329563400943);
[0.58333333333333337, 0.62285714285714289], [0.8936170212765957, 0.76000000000000001], (0.80565735169264896, 0.75578523763882166, 0.10757369310766951);
[0.36170212765957449, 0.76000000000000001], [0.8936170212765957, 1.0], (0.57042872206220896, 0.9335301149492965, 0.86254084187238389);
[0.36170212765957449, 0.76000000000000001], [0.62765957446808507, 1.0], (0.31530318311042171, 0.97066142447913661, 0.93180609525183578);
[0.62765957446808507, 0.76000000000000001], [0.8936170212765957, 1.0], (0.18330061581424317, 0.82234170300788867, 0.38303955663618716);
[0.8936170212765957, 0.0], [1.0, 1.0], (0.20641218447120302, 0.35715481613716149, 0.86620796882602547);
[0.8936170212765957, 0.0], [1.0, 0.59999999999999998], (0.7942020522649591, 0.27351921049542915, 0.86191731793444748);
[0.8936170212765957, 0.59999999999999998], [1.0, 1.0], (0.27214488578650742, 0.41635201268319189, 0.1301335726270938);
]
(*e: concrete rectangles example *)
(*s: variable tree_ex_shneiderman_1991 *)
let tree_ex_shneiderman_1991 =
let ninfo = () in
Node (ninfo, [
Leaf 12;
Leaf 6;
Node (ninfo, [
Leaf 2;
Leaf 2;
Leaf 2;
Leaf 2;
Leaf 2;
]);
Node(ninfo, [
Node(ninfo, [
Leaf 5;
Leaf 20;
]);
Node(ninfo, [
Leaf 5;
]);
Leaf 40;
]);
])
(*e: variable tree_ex_shneiderman_1991 *)
(*s: variable tree_ex_wijk_1999 *)
let tree_ex_wijk_1999 =
let ninfo = () in
Node (ninfo, [
Leaf 6;
Leaf 6;
Leaf 4;
Leaf 3;
Leaf 2;
Leaf 2;
Leaf 1;
])
(*e: variable tree_ex_wijk_1999 *)
(*s: variable treemap_ex_ordered_2001 *)
let (treemap_ex_ordered_2001: (unit, unit) treemap) =
let children = children_ex_ordered_2001 in
let children_treemap =
children +> Common.index_list_1 +> List.map (fun (size, i) ->
Leaf ({
size = size;
color = Color.color_of_string (spf "grey%d" (90 - (i * 3)));
label = spf "size = %d" size;
}, ())
)
in
let total_size = Common.sum children in
Node (({
size = total_size;
color = Color.black;
label = "";
}, ()), children_treemap
)
(*e: variable treemap_ex_ordered_2001 *)
(*****************************************************************************)
(* Actions *)
(*****************************************************************************)
let actions () = [
(*s: treemap actions *)
"-test_squarify", "<>",
Common.mk_action_0_arg (test_squarify);
"-test_orderify", "<>",
Common.mk_action_0_arg (test_orderify);
(*e: treemap actions *)
]
(*e: treemap.ml *)
Jump to Line
Something went wrong with that request. Please try again.