← Back to branch summary

~ubuntu-branches/ubuntu/utopic/circos/utopic

« back to all changes in this revision

Viewing changes to .pc/configpath_add_etc/lib/Circos/Utils.pm

  • Committer: Package Import Robot
  • Author(s): Olivier Sallou
  • Date: 2013-05-20 09:01:27 UTC
  • mfrom: (1.1.3)
  • Revision ID: package-import@ubuntu.com-20130520090127-s5nbumg8563x00ee
Tags: 0.64-1
New upstream release

Show diffs side-by-side

added added

removed removed

Lines of Context:
.pc/configpath_add_etc/lib/Circos/Utils.pm
72
72
is_blank
73
73
is_comment
74
74
make_set
 
75
span_distance
75
76
show
76
77
hide
77
78
use_set
78
79
true_or_yes
79
80
false_or_no
80
81
parse_options
 
82
get_hash_leaf
 
83
log10
81
84
);
82
85
 
83
86
use Carp qw( carp confess croak );
130
133
#################################################################
131
134
# 
132
135
sub remap {
 
136
 
133
137
        my ($value,$min,$max,$remap_min,$remap_max) = @_;
134
138
        if (! defined $value ||
135
139
                        ! defined $min ||
138
142
                        ! defined $remap_max) {
139
143
                fatal_error("function","remap_wrong_num_args");
140
144
        }
 
145
 
141
146
        return $remap_min if $value <= $min;
142
147
        return $remap_max if $value >= $max;
143
148
 
221
226
 
222
227
sub parse_as_rx {
223
228
        my $rx = shift;
224
 
        if ($rx =~ /^-?\/(.+)\/$/) {
 
229
        return if ! defined $rx;
 
230
        if ($rx =~ /^\s*-?\/(.+)\/\s*$/) {
225
231
                return qr/$1/;
226
232
        } else {
227
233
                return;
369
375
  # seek_parameter("x|y",$hash,$anotherhash);
370
376
  my ( $param_name, @data_structs ) = @_;
371
377
  my @target_string = split( /\|/, $param_name );
 
378
        my $not_def_ok = 1;
372
379
  start_timer("parameter_seek");
373
380
  for my $str (@target_string) {
374
381
    for my $struct (@data_structs) {
375
382
      if ( ref($struct) eq "ARRAY" ) {
376
383
                                for my $substruct (@$struct) {
377
 
                                        if (exists $substruct->{param} && defined $substruct->{param}{$str}) {
 
384
                                        if (exists $substruct->{param} &&
 
385
                                                        exists $substruct->{param}{$str} && ($not_def_ok || defined $substruct->{param}{$str})) {
378
386
                                                stop_timer("parameter_seek");
379
387
                                                return $substruct->{param}{$str};
380
388
                                        }
381
 
                                        if (exists $substruct->{$str}  && defined $substruct->{$str}) {
 
389
                                        if (exists $substruct->{$str}  && ($not_def_ok || defined $substruct->{$str})) {
382
390
                                                stop_timer("parameter_seek");
383
391
                                                return $substruct->{$str};
384
392
                                        }
385
393
                                }
386
394
      } elsif ( ref($struct) eq "HASH" ) {
387
 
                                if (exists $struct->{param} && defined $struct->{param}{$str}) {
 
395
                                if (exists $struct->{param} &&
 
396
                                                exists $struct->{param}{$str} &&
 
397
                                                ($not_def_ok || defined $struct->{param}{$str})) {
388
398
                                        stop_timer("parameter_seek");
389
399
                                        return $struct->{param}{$str};
390
400
                                }
391
 
                                if (exists $struct->{$str} && defined $struct->{$str}) {
 
401
                                if (exists $struct->{$str} && ($not_def_ok || defined $struct->{$str})) {
392
402
                                        stop_timer("parameter_seek");
393
403
                                        return $struct->{$str};
394
404
                                }
430
440
        }
431
441
 
432
442
        # look for the file in various directories
433
 
        my @dir_1 = (getcwd,$FindBin::RealBin);
 
443
        # v0.63 added configuration directory to dir_1
 
444
        my @dir_1 = grep($_,getcwd,Circos::Configuration::fetch_conf("configdir"),$FindBin::RealBin);
434
445
        my @dir_2 = qw(. .. ../.. ../../..);
435
446
        my @dir_3 = qw(. etc data);
436
 
        
 
447
 
437
448
        my $file   = $params{file};
438
449
        # remove any comma-delimited elements from the file
439
450
        $file =~ s/,.*//;
440
451
        printdebug_group("io","locating file",$file,"role",$params{name});
441
 
    
 
452
 
442
453
        if (! defined $file) {
443
454
                confess "Attempted to locate an undefined file name for [$params{name}]";
444
455
        }
445
 
    
 
456
 
446
457
        my @path;
447
 
        if ($file =~ /^\//) {
 
458
        if (file_name_is_absolute($file)) {
448
459
                @path = ($EMPTY_STR);
449
460
        } else {
450
461
                # first add any custom path directories
463
474
        }
464
475
        printdebug_group("io","trying path",@path);
465
476
        for my $path (@path) {
466
 
                my $file_path = catfile($path,$file);
 
477
                my $file_path = $path ? catfile($path,$file) : $file;
467
478
                printdebug_group("io","trying $file_path");
468
479
                if ( -e $file_path) {
469
480
            if (! -r $file_path) {
566
577
        return map { ($_,$x{$_}) } grep(defined $x{$_}, keys %x);
567
578
}
568
579
 
 
580
# return the distance between the span
 
581
# [x1,y1] and [x2,y2]
 
582
# if the spans overlap, the distance is negative
 
583
sub span_distance {
 
584
  my ($x1,$y1,$x2,$y2) = @_;
 
585
  # flip the coordinates if they are reversed
 
586
  ($x1,$y1) = ($y1,$x1) if $x1 > $y1;
 
587
  ($x2,$y2) = ($y2,$x2) if $x2 > $y2;
 
588
  # flip intervals so that x1,y1 is always to the left
 
589
  ($x1,$y1,$x2,$y2) = ($x2,$y2,$x1,$y1) if ($x1 > $x2);
 
590
  my $d;
 
591
  if ($x2 >= $y1) {
 
592
    # x1 y1
 
593
    # -----  
 
594
    #        x2  y2
 
595
    #        ------
 
596
    $d = $x2 - $y1;
 
597
  } else {
 
598
    if ($y2 >= $y1) {
 
599
      # x1     y1
 
600
      # ---------
 
601
      #     x2    y2
 
602
      #     --------
 
603
      $d = -($y1 - $x2);
 
604
    } else {
 
605
      # x1     y1
 
606
      # ---------
 
607
      #   x2  y2
 
608
      #   ------
 
609
      $d = -($y2-$x2);
 
610
    }
 
611
  }
 
612
  die "did not calculate distance between intervals [$x1,$y1] and [$x2,$y2] correctly." unless defined $d;
 
613
  return $d;
 
614
 
 
615
  # test
 
616
  for my $i (0..100000) {
 
617
    my @coords = map { sprintf("%.1f",100*rand()) } (0..3);
 
618
    my $s1 = Set::IntSpan->new(sprintf("%d-%d",sort {$a <=> $b} ($coords[0]*1000,$coords[1]*1000)));
 
619
    my $s2 = Set::IntSpan->new(sprintf("%d-%d",sort {$a <=> $b} ($coords[2]*1000,$coords[3]*1000)));
 
620
    my $int = $s1->intersect($s2)->cardinality;
 
621
    my $d   = span_distance(@coords);
 
622
    if ($int) {
 
623
      $int = ($int-1)/1000 if $int;
 
624
      if ($int && (-$d - $int) > 0.002) {
 
625
                                die();
 
626
      }
 
627
    } else {
 
628
      $int = min ( abs($coords[0] - $coords[2]),
 
629
                                                                         abs($coords[0] - $coords[3]),
 
630
                                                                         abs($coords[1] - $coords[2]),
 
631
                                                                         abs($coords[1] - $coords[3]) );
 
632
      if ($d - $int > 0.002) {
 
633
                                die();
 
634
      }
 
635
    }
 
636
    printinfo(@coords,$d,$int);
 
637
  }
 
638
}
 
639
 
569
640
sub make_set {
570
641
        my ($x,$y,%args) = @_;
571
642
        if (! defined $x) {
607
678
        return if $x eq 0 || $x =~ /^no?$/i;
608
679
}
609
680
 
 
681
sub get_hash_leaf {
 
682
        my ($hash,@path) = @_;
 
683
        return $hash if ! @path;
 
684
        my $key = shift @path;
 
685
        if(! exists $hash->{$key}) {
 
686
                fatal_error("system","hash_leaf_undef",$key);
 
687
        } else {
 
688
                return get_hash_leaf($hash->{$key},@path);
 
689
        }
 
690
}
 
691
 
610
692
# -------------------------------------------------------------------
611
693
# parse into a hash option string like
612
694
#   var1=value1,var2=value2,...
622
704
  return $options;
623
705
}
624
706
 
 
707
sub log10 {
 
708
        my $x = shift;
 
709
        return $x > 0 ? log($x)/log(10) : undef;
 
710
}
 
711
 
625
712
1;