view release on metacpan or  search on metacpan

lib/Bio/DB/BigWigSet.pm  view on Meta::CPAN

    }

    # create a lazy loading bigwig for each file
    for my $file (@$wigfiles) {
	$self->add_bigwig($file);
	my $name  = basename($file,'.bw');
	$self->set_bigwig_attributes($file,
				     {
					 display_name=>$name,
					 dbid        =>$file,
				     });
    }

    # read the tables of attributes
    for my $file (@$indices) {
	$self->read_index($file,$dir);
    }
}

sub read_local_dir {
    my $self = shift;
    my $dir  = shift;
    croak "directory $dir doesn't exist" unless -d $dir;
    croak "directory $dir not readable"  unless -r _;

    my (@indices,@wigfiles);
    my $d = IO::Dir->new($dir);
    while (my $node = $d->read) {
	next if $node =~ /^[.#]/; # dot files and temp files
	next if $node =~ /~$/;    # autosave files
	my $file = File::Spec->catfile($dir,$node);
	next unless -f $file;
	if ($node =~ /^meta/) {
	    push @indices,$file;
	} elsif ($node =~ /\.bw/i) {
	    push @wigfiles,$file;
	}
    }
    undef $d;
    return (\@wigfiles,\@indices);
}

sub read_remote_dir {
    my $self = shift;
    my $dir  = shift;

    eval "require LWP::UserAgent;1" or die "LWP is required to handle remote directories"
	unless LWP::UserAgent->can('new');

    eval "require URI::URL;1"       or die "URI::URL is required to handle remote directories"
	unless URI::URL->can('new');

    my $ua  = LWP::UserAgent->new;
    my $response = $ua->get($dir,Accept=>'text/html, */*;q=0.1');

    unless ($response->is_success) {
	warn "Web fetch of $dir failed: ",$response->status_line;
	return;
    }

    my $html = $response->decoded_content;
    my $base = $response->base;
    my @wigfiles = map {URI::URL->new($_=>$base)->abs} $html =~ /href="([^\"]+\.bw)"/ig;
    my @indices  = map {URI::URL->new($_=>$base)->abs} $html =~ /href="(meta[^\"]*)"/ig;
    return (\@wigfiles,\@indices);
}


=item $bws->add_bigwig($path)

Given a path to a .bw file, add the BigWig file to the set.

=cut

sub add_bigwig {
    my $self = shift;
    my $path = shift;
    $self->{bigwigs}{$path} = undef;  # lazy loading
}

=item $bws->remove_bigwig($path)

Given a path to a .bw file, removes it from the set.

=cut

sub remove_bigwig {
    my $self = shift;
    my $path = shift;
    delete $self->{bigwigs}{$path};
    delete $self->{attributes}{$path};
}

=item $bws->set_bigwig_attributes($path,$attributes)

Given the path to a BigWig file, assign metadata to it. The second
argument is a hash in which the keys are attribute names such as
"type" and the values are the values of those attributes.

If the BigWig file is not already part of the set, it is added (as in
add_bigwig()).

=cut

sub set_bigwig_attributes {
    my $self = shift;
    my ($path,$attributes) = @_;
    if (my $old = $self->{attributes}{$path}) {
	%$attributes = (%$old,%$attributes);  # merge
    }
    $self->{bigwigs}{$path}  ||= undef;
    $self->{attributes}{$path} = $attributes;
}

=item @paths = $bws->bigwigs

Returns the path to all the BigWig files in the collection.

=cut

sub bigwigs {
    my $self = shift;
    return keys %{$self->{bigwigs}};
}

=item $bigwig = $bws->get_bigwig($path)

If the BigWig file is part of the set, opens and returns it.

=back

=cut

sub get_bigwig {
    my $self = shift;
    my $path = shift;
    return unless exists $self->{bigwigs}{$path};
    my $bw = $self->{bigwigs}{$path} ||=
	Bio::DB::BigWig->new(-bigwig => $path,
			     -fasta  => $self->dna_accessor||undef) 
	or die "Could not open bigwig file $path: $!";
    return $bw;
}

sub read_index {
    my $self = shift;
    my ($file,$base) = @_;
    $base ||= dirname($file);
    my $f;

    if ($file =~ /^(ftp|http):/i) {
	my $ua = LWP::UserAgent->new;
	my $r  = $ua->get($file);
	die "Couldn't read $file: ",$r->status_line unless $r->is_success;
	eval "require IO::String; 1" 
	    or die "IO::String module is required for remote directories"
	    unless IO::String->can('new');
	$f = IO::String->new($r->decoded_content);
    }
    else {
	$f = IO::File->new($file) or die "$file: $!";
    }
    my ($current_path,%wigs);

    while (<$f>) {
	chomp;
	s/\s+$//;   # strip whitespace at ends of lines
	# strip right-column comments unless they look like colors or html fragments
	s/\s*\#.*$// unless /\#[0-9a-f]{6,8}\s*$/i || /\w+\#\w+/ || /\w+\"*\s*\#\d+$/;   
	if (/^\[([^\]]+)\]/) {  # beginning of a configuration section
	    my $wigname = $1;
	    $current_path    = $wigname =~ m!^(/|http:|ftp:)! ? $wigname
		                                              : "$base/$wigname";
	}

	elsif ($current_path && /^([\w: -]+?)\s*=\s*(.*)/) {  # key value pair
	    my $tag = lc $1;
	    my $value = defined $2 ? $2 : '';
	    $wigs{$current_path}{$tag}=$value;
	}
    }

    for my $path (keys %wigs) {
	my $attributes = $wigs{$path};
	$self->set_bigwig_attributes($path,$attributes);
    }
}

sub segment {
    my $self = shift;
    my ($seqid,$start,$end) = @_;

    if ($_[0] =~ /^-/) {
	my %args = @_;
	$seqid = $args{-seq_id} || $args{-name};
	$start = $args{-start};
	$end   = $args{-stop}    || $args{-end};
    } else {
	($seqid,$start,$end) = @_;
    }

    my ($one_bigwig) = keys %{$self->{bigwigs}};
    my $bw           = $self->get_bigwig($one_bigwig);

    my $size = $bw->length($seqid) or return;

    $start ||= 1;
    $end   ||= $bw->length($seqid);

    return unless $start >= 1 && $start < $size;
    return unless $end   >= 1 && $end   < $size;

    return Bio::DB::BigWigSet::Segment->new(-bws   => $self,
					    -seq_id=> $seqid,
					    -start => $start,
					    -end   => $end);
}