libgo-perl 0.15-1 / usr / share / perl5 / GO / Utils.pm

# $Id: Utils.pm,v 1.2 2004/11/24 02:28:00 cmungall Exp $
#
# This GO module is maintained by Chris Mungall <cjm@fruitfly.org>
#
# see also - http://www.geneontology.org
#          - http://www.godatabase.org/dev
#
# You may distribute this module under the same terms as perl itself

package GO::Utils;

use Exporter;

@ISA = qw(Exporter);

@EXPORT_OK = qw(rearrange remove_duplicates merge_hashes get_method_ref
	       get_param pset2hash dd spell_greek max check_obj_graph);

use strict;
use Carp;
use Data::Dumper;

=head1 NAME

GO::Utils - utilities for GO modules

=head2 rearrange()

 Usage    : n/a
 Function : Rearranges named parameters to requested order.
 Returns  : @params - an array of parameters in the requested order.
 Argument : $order : a reference to an array which describes the desired
                     order of the named parameters.
            @param : an array of parameters, either as a list (in
                     which case the function simply returns the list),
                     or as an associative array (in which case the
                     function sorts the values according to @{$order}
                     and returns that new array.

 Exceptions : carps if a non-recognised parameter is sent

=cut

sub rearrange {
  # This function was taken from CGI.pm, written by Dr. Lincoln
  # Stein, and adapted for use in Bio::Seq by Richard Resnick.
  # ...then Chris Mungall came along and adapted it for BDGP
  my($order,@param) = @_;

  # If there are no parameters, we simply wish to return
  # an undef array which is the size of the @{$order} array.
  return (undef) x $#{$order} unless @param;

  # If we've got parameters, we need to check to see whether
  # they are named or simply listed. If they are listed, we
  # can just return them.
  return @param unless (defined($param[0]) && $param[0]=~/^-/);

  # Now we've got to do some work on the named parameters.
  # The next few lines strip out the '-' characters which
  # preceed the keys, and capitalizes them.
  my $i;
  for ($i=0;$i<@param;$i+=2) {
      if (!defined($param[$i])) {
	  carp("Hmmm in $i ".join(";", @param)." == ".join(";",@$order)."\n");
      }
      else {
	  $param[$i]=~s/^\-//;
	  $param[$i]=~tr/a-z/A-Z/;
      }
  }
  
  # Now we'll convert the @params variable into an associative array.
  my(%param) = @param;

  my(@return_array);
  
  # What we intend to do is loop through the @{$order} variable,
  # and for each value, we use that as a key into our associative
  # array, pushing the value at that key onto our return array.
  my($key);

  foreach $key (@{$order}) {
      $key=~tr/a-z/A-Z/;
      my($value) = $param{$key};
      delete $param{$key};
      push(@return_array,$value);
  }
  
  # catch user misspellings resulting in unrecognized names
  my(@restkeys) = keys %param;
  if (scalar(@restkeys) > 0) {
       carp("@restkeys not processed in rearrange(), did you use a
       non-recognized parameter name ? ");
  }
  return @return_array;
}




=head2 get_param()

Usage    : get_param('name',(-att1=>'ben',-name=>'the_name'))
Function : Fetches a  named parameter.
Returns  : The value of the requested parameter.
Argument : $name : The name of the the parameter desired
           @param : an array of parameters, as an associative array 
Exceptions : carps if a non-recognised parameter is sent

Based on rearrange(), which is originally from CGI.pm by Lincoln
Stein and BioPerl by Richard Resnick.  See rearrange() for details.

=cut

sub get_param
  {

  # This function was taken from CGI.pm, written by Dr. Lincoln
  # Stein, and adapted for use in Bio::Seq by Richard Resnick.
  # ...then Chris Mungall came along and adapted it for BDGP
    # ... and ben berman added his 2 cents.

  my($name,@param) = @_;

  # If there are no parameters, we simply wish to return
  # false.
  return '' unless @param;

  # If we've got parameters, we need to check to see whether
  # they are named or simply listed. If they are listed, we
  # can't return anything.
  return '' unless (defined($param[0]) && $param[0]=~/^-/);

  # Now we've got to do some work on the named parameters.
  # The next few lines strip out the '-' characters which
  # preceed the keys, and capitalizes them.
  my $i;
  for ($i=0;$i<@param;$i+=2) {
        $param[$i]=~s/^\-//;
        $param[$i] = uc($param[$i]);
  }
  
  # Now we'll convert the @params variable into an associative array.
  my(%param) = @param;

  # We capitalize the key, and use it as a key into our
  # associative array
  my $key = uc($name);
  my $val = $param{$key};

  return $val;
}






























=head2 remove_duplicates

remove duplicate items from an array

 usage: remove_duplicates(\@arr)

affects the array passed in, and returns the modified array

=cut

sub remove_duplicates {
    
    my $arr_r = shift;
    my @arr = @{$arr_r};
    my %h = ();
    my $el;
    foreach $el (@arr) {
	$h{$el} = 1;
    }
    my @new_arr = ();
    foreach $el (keys %h) {
	push (@new_arr, $el);
    }
    @{$arr_r} = @new_arr;
    @new_arr;
}

=head1 merge_hashes

joins two hashes together

 usage: merge_hashes(\%h1, \%h2);

%h1 will now contain the key/val pairs of %h2 as well. if there are
key conflicts, %h2 values will take precedence.

=cut

sub merge_hashes {
    my ($h1, $h2) = @_;
    map {
	$h1->{$_} = $h2->{$_};
    } keys %{$h2};
    return $h1;
}

=head1 get_method_ref

 returns a pointer to a particular objects method
 e.g.   my $length_f = get_method_ref($seq, 'length');
        $len = &$length_f();

=cut

sub get_method_ref {
    my $self = shift;
    my $method = shift;
    return sub {return $self->$method(@_)};
}


=head2 pset2hash

  Usage   - my $h = pset2hash([{name=>"id", value=>"56"}, {name=>"name", value=>"jim"}]);
  Returns - hashref
  Args    - arrayref of name/value keyed hashrefs

=cut

sub pset2hash {
    my $pset = shift;
    my $h = {};
    # printf STDERR "REF=%s;\n", ref($pset);
    if (ref($pset) eq "ARRAY") {
	map {$h->{$_->{name}} = $_->{value}} @$pset;
    }
    elsif (ref($pset) eq "HASH") {
	$h = $pset;
    }
    else {
        $h = $pset;
    }
    return $h;
}

sub dd {
    my $obj = shift;
    my $d= Data::Dumper->new(['obj',$obj]);
    print $d->Dump;
}
  
=head2 spell_greek

takes a word as a parameter and spells out any greek symbols encoded
within (eg s/&agr;/alpha/g)

=cut

sub spell_greek
{
    my $name = shift;

    $name =~ s/&agr\;/alpha/g;
    $name =~ s/&Agr\;/Alpha/g;
    $name =~ s/&bgr\;/beta/g;
    $name =~ s/&Bgr\;/Beta/g;
    $name =~ s/&ggr\;/gamma/g;
    $name =~ s/&Ggr\;/Gamma/g;
    $name =~ s/&dgr\;/delta/g;
    $name =~ s/&Dgr\;/Delta/g;
    $name =~ s/&egr\;/epsilon/g;
    $name =~ s/&Egr\;/Epsilon/g;
    $name =~ s/&zgr\;/zeta/g;
    $name =~ s/&Zgr\;/Zeta/g;
    $name =~ s/&eegr\;/eta/g;
    $name =~ s/&EEgr\;/Eta/g;
    $name =~ s/&thgr\;/theta/g;
    $name =~ s/&THgr\;/Theta/g;
    $name =~ s/&igr\;/iota/g;
    $name =~ s/&Igr\;/Iota/g;
    $name =~ s/&kgr\;/kappa/g;
    $name =~ s/&Kgr\;/Kappa/g;
    $name =~ s/&lgr\;/lambda/g;
    $name =~ s/&Lgr\;/Lambda/g;
    $name =~ s/&mgr\;/mu/g;
    $name =~ s/&Mgr\;/Mu/g;
    $name =~ s/&ngr\;/nu/g;
    $name =~ s/&Ngr\;/Nu/g;
    $name =~ s/&xgr\;/xi/g;
    $name =~ s/&Xgr\;/Xi/g;
    $name =~ s/&ogr\;/omicron/g;
    $name =~ s/&Ogr\;/Omicron/g;
    $name =~ s/&pgr\;/pi/g;
    $name =~ s/&Pgr\;/Pi/g;
    $name =~ s/&rgr\;/rho/g;
    $name =~ s/&Rgr\;/Rho/g;
    $name =~ s/&sgr\;/sigma/g;
    $name =~ s/&Sgr\;/Sigma/g;
    $name =~ s/&tgr\;/tau/g;
    $name =~ s/&Tgr\;/Tau/g;
    $name =~ s/&ugr\;/upsilon/g;
    $name =~ s/&Ugr\;/Upsilon/g;
    $name =~ s/&phgr\;/phi/g;
    $name =~ s/&PHgr\;/Phi/g;
    $name =~ s/&khgr\;/chi/g;
    $name =~ s/&KHgr\;/Chi/g;
    $name =~ s/&psgr\;/psi/g;
    $name =~ s/&PSgr\;/Psi/g;
    $name =~ s/&ohgr\;/omega/g;
    $name =~ s/&OHgr\;/Omega/g;
    $name =~ s/<up>/\[/g;
    $name =~ s/<\/up>/\]/g;
    $name =~ s/<down>/\[\[/g;
    $name =~ s/<\/down>/\]\]/g;

    return $name;
}


=head2 check_obj_graph

  Usage   -
  Returns - true if cycle detected
  Args    - any object

=cut

sub check_obj_graph {
    my $object = shift;
    
    my $h = {};
    my $cnt = 1;
    my @nodes = ({obj=>$object,path=>[]});
    my @path = ();
    my $cycle = 0;
    while (!$cycle && @nodes) {
	my $node = shift @nodes;
	my $obj = $node->{obj};
	my $id = sprintf("%s", $node->{obj});
	if (ref($obj) && $id !~ /GLOB/) {
	    
	    if (!$h->{$id}) {
		$h->{$id} = $cnt;
		$cnt++;
	    }
	    
	    # check for cycles
	    if (grep {my $idelt = sprintf("%s", $_); $idelt eq $id}
		@{$node->{path}}) {
		$cycle = $node;
	    }

	    printf 
	      "* OB:%5s %20s [%s]\n",
	      $h->{$id},
	      $obj,
	      join(", ", map {$h->{$_}} @{$node->{path}});

	    my @newobjs = ();
	    if (ref($obj) eq "ARRAY") {
		@newobjs = @$obj;
	    }
##	    if (ref($obj) eq "HASH") {
	    elsif (ref($obj) eq "GLOB") {
	    }
	    else {
		@newobjs = values %$obj;
	    }
	    map {
		my @newpath = (@{$node->{path}}, $obj);
		my $newnode = {obj=>$_, path=>\@newpath};
		push(@nodes, $newnode);
	    } @newobjs;
	}
    }
    return $cycle;

}



sub max
  {
    my @items = @_;

    my $max;
    my $item;
    foreach $item (@items)
      {
        if (!defined($max))
          {
            $max = $item;
          }
        else
          {
            $max = $item if ($item > $max);
          }
      }

    return $max;
  }



1;