Mercurial > repos > davidvanzessen > mutation_analysis
diff template.pm @ 2:2f4298673519 draft
Uploaded
| author | davidvanzessen |
|---|---|
| date | Wed, 10 Sep 2014 10:33:29 -0400 |
| parents | |
| children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/template.pm Wed Sep 10 10:33:29 2014 -0400 @@ -0,0 +1,672 @@ +=head1 NAME + + template.pm - creates logo output in various formats + +=head1 SYNOPSIS + + Perl module + +=head1 DESCRIPTION + + logo.cgi and run.pl collect the logo data. They can then enter + template::create_template to create logo output in the following formats: + + * EPS + * GIF + * PDF + * PNG + + + + If the configuration file "logo.conf" exists in the working directory, then + it will be parsed for the locations of GhostScript (gs) and convert. The + following is an + example of the configuration file ("#" at beginning of line indicates + comment): + + # Make configuration changes here. Rename this file to logo.conf + # gs version 5.5 does not work, 6.5 does + # set the PATHS + gs=/usr/local/bin/gs + convert=/usr/X11R6/bin/convert + +=cut + +package template; +use strict; + + +################################################################################ +######## STATE FOR FILLINGS ########## +################################################################################ + +# BARBITS number of bits in vertical y-axis bar +# CHARWIDTH width of characters in logo +# COLORSCHEME "a" for amino acid; +# "n" for nucleic acid; +# "b" for black (no color scheme) +# color scheme +# DATA string of heights of characters in cm +# DESC description of aligned sequences +# FINEPRINT enable adverts/credits +# LOGOLINES number of lines of logo +# LOGOHEIGHT height of EACH LINE in logo (in cm) +# LOGOWIDTH width of final logo in cm +# LOGOHEIGHTPOINTS height of final logo in points +# LOGOWIDTHPOINTS height of final logo in points +# LOGOSTART logo output will begin at residue LOGOSTART +# LOGOEND logo output will end at residue LOGOEND +# ERRBAR 1 to include error bar, 0 to exclude +# ERRORBARFRACTION percent of error bar to show in range [0,1] +# KIND $AA for amino acid, $NA for nucleic acid +# NUMBERING 1 to show residue numbers, 0 to exclude +# OUTLINE 1 to print characters in outline form; +# 0 to print characters in solid form +# SHOWENDS "d" to show 5' and 3' ends; +# "p" to show N and C termini; +# "-" to exclude end markers +# SHOWINGBOX "n" to have No boxes around characters; +# "s" to have boxes around characters, with Shrinking; +# "f" to have Filled boxes around characters +# SHRINKBOOLEAN 1 to shrink characters; 0 to exclude shrinking +# SHRINKFACTOR amount to shrink in range from 1(no shrinking) to +# 0(full shrinking) +# START_NUM start number for very beginning of sequence +# TITLE title of logo +# YAXIS 1 to turn on y axis and its labels + +################################################################################ +##### VARIABLES AND DEFAULT VALUES ##### +################################################################################ + +my %defaults = ( + LOGOHEIGHT => 5, + LOGOWIDTH => 8, + + YAXIS => "false", + TITLE => "", + YAXIS_LABEL => "bits", + XAXIS_LABEL => "", + + BARENDS => "false", + OUTLINE => "false", + SHOWINGBOX => "n", + NUMBERING => "false", + #FINEPRINT => "Created by: G. E. Crooks, G. Hon, J.-M. Chandonia & S. E. Brenner, (2002) <weblogo.berkeley.edu>", + FINEPRINT => "weblogo.berkeley.edu", + + ERRORBARFRACTION => "1", + ERRBAR => "0", + SHRINKFACTOR => "1", + START_NUM => "1", + + DEFAULT_COLOR => "black", + + black => "[0 0 0]", + red => "[0.8 0 0]", + green => "[0 0.8 0]", + blue => "[0 0 0.8]", + yellow => "[1 0.7 1.0]", + purple => "[0.8 0 0.8]", + orange => "[1 0.7 0]" + ); + +my $AA = 0; +my $NA = 1; +my $PATH; + +################################################################################ +##### SOME FUNCTIONS ##### +################################################################################ + + +sub create_template { + my ($input, $kind, $desc_r, $data_r, $outfile, $path) = @_; + + # set path + $PATH = $path; + + #Create EPS file + my %fillings; + + # put parameters in fillings + makeFillings(\%fillings, $input, $kind, $desc_r, $defaults{FINEPRINT}); + + # set default data if not filled + setDefaults(\%fillings, \%defaults, scalar @$data_r); + + # put color in fillings + setColors(\%fillings, \%defaults); + + # put data in fillings + setData(\%fillings, $data_r); + + # make eps output + my $eps = fillTemplate("$PATH/template.eps", \%fillings); + my $format = $input->{FORMAT}; + + # convert + my ($gsprog, $convertprog) = getProgs(); + +# print STDERR "(gsprog, convertprog) = ($gsprog, $convertprog)\n"; + + my $width = $fillings{LOGOWIDTHPOINTS}; + my $height = $fillings{LOGOHEIGHTPOINTS}; # height of entire logo + my $res = $input->{RES}; + my $antialias = (defined $input->{ANTIALIAS} && $input->{ANTIALIAS}) ? "-dTextAlphaBits=4" : ""; + + my $r = $width . "x" . $height; + + if( $format eq "EPS" ) { + if ($outfile eq "-") { # if standard out + print $eps; + } else { + open (WRITEME, ">$outfile"); + print WRITEME $eps; + close (WRITEME); + } + + } elsif ($format eq "PDF"){ +# print("outfile = $outfile\n"); + my $program = "| $gsprog -sOutputFile=$outfile -sDEVICE=pdfwrite -dPDFSETTINGS=/printer -q -r$res -dDEVICEWIDTHPOINTS=$width -dDEVICEHEIGHTPOINTS=$height -dEmbedAllFonts=true $antialias -dSAFER -dBATCH -dNOPAUSE -_"; + open(WRITEME, $program); + print WRITEME "$eps"; + close (WRITEME); + + } elsif ( $format eq "PNG" ) { + my $program = "| $gsprog -sOutputFile=$outfile -sDEVICE=png16m -q -r$res -dDEVICEWIDTHPOINTS=$width -dDEVICEHEIGHTPOINTS=$height $antialias -dSAFER -dBATCH -dNOPAUSE -_"; + #print ("$program"); + open(WRITEME, $program); + print WRITEME "$eps"; + close (WRITEME); + + } elsif ($format eq "GIF") { + # convert to EPS first, then GIF + die "Please check logo.conf: convert program does not exist" + if (!defined $convertprog || !(-e $convertprog)); + + my $program = "| $gsprog -sOutputFile=- -sDEVICE=png16m -q -r$res -dDEVICEWIDTHPOINTS=$width -dDEVICEHEIGHTPOINTS=$height $antialias -dSAFER -dBATCH -dNOPAUSE -_"; + + if ($outfile eq "-") { + $program .= " | $convertprog png:- gif:-"; + } else { + $program .= " | $convertprog png:- $outfile"; + } + + open(WRITEME, $program); + print WRITEME "$eps"; + close (WRITEME); + } +} + +#deprecated +sub c { + return create_template( @_); +} + +sub getProgs { + my ($gsprog, $convertprog) = ("gs", "convert"); + + + # No configuration file, then return defaults. + return ($gsprog, $convertprog) if (! (-e "$PATH/logo.conf")); + open (CONF, "$PATH/logo.conf"); + + while (<CONF>) { + next if (/^\#/); # skip lines beginning with "#" + if (m/^gs/i) { # if looks like gs (case insensitive) + ($gsprog) = ($_ =~ /^\S+\=(.+)$/); + } + if (m/^convert/i) { # if looks like convert (case insensitive) + ($convertprog) = ($_ =~ /^\S+\=(.+)$/); + } + } + + # Do these fings exist? + my ($gsprogname) = ($gsprog =~ /^(\S+)/); + + die "Please check $PATH/logo.conf: gs program ($gsprogname) does not exist" if (!defined $gsprogname || !(-e $gsprogname)); + #die "Please check logo.conf: convert program does not exist" if (!defined $convertprog || !(-e $convertprog)); + + return ($gsprog, $convertprog); +} + +sub get_eps { + my ($input, $kind, $desc_r, $data_r) = @_; + my %fillings; + + # put parameters in fillings + makeFillings(\%fillings, $input, $kind, $desc_r); + + # set default data if not filled + setDefaults(\%fillings, \%defaults, $#$data_r); + + # put data in fillings + setData(\%fillings, $data_r); + + # make output + return fillTemplate("$PATH/template.eps", \%fillings); +} + +sub fillTemplate { + my ($filename, $fillings) = @_; + + if (not -e $filename) { + die "filename ($filename) must exist\n"; + } + + my $text; + local $/; # slurp mode (undef) + local *F; # create local filehandle + open(F, "< $filename\0") || return; + $text = <F>; + close(F); + + #replace {$KEYWORDS} with value in %$fillings hash + $text =~ s{ \{\$ (.*?) \} } + { exists( $fillings->{$1}) + ? $fillings->{$1} + : "" + }gsex; + return $text; +} + + +################################################################################ +##### FILL THE FILLINGS HERE ##### +################################################################################ + +sub isChecked { + return 0 if (!defined $_[0]); + return $_[0]; +} + +# negative/positive ints +sub isInt { + return ($_[0] =~ /^[-\+]?\d+$/) ? 1 : 0; +} + +sub makeFillings { + +# my ($fillings, $input, $kind, $desc_r, $data_r, $fineprint) = @_; + my ($fillings, $input, $kind, $desc_r, $fineprint) = @_; + $fillings->{KIND} = $kind; + $fillings->{LOGOHEIGHT} = $input->{LOGO_HEIGHT}; + $fillings->{LOGOWIDTH} = $input->{LOGO_WIDTH}; + $fillings->{OUTLINE} = (isChecked($input->{OUTLINE})) ? "true" : "false"; + $fillings->{NUMBERING} = (isChecked($input->{NUMBERING})) ? "true" : "false"; + $fillings->{FINEPRINT} = (isChecked($input->{FINEPRINT})) ? $fineprint : ""; + + $fillings->{LOGOSTART} = $input->{LOGOSTART}; + $fillings->{LOGOEND} = $input->{LOGOEND}; + $fillings->{START_NUM} = $input->{START_NUM}; + + $fillings->{YAXIS} = (isChecked($input->{YAXIS}) && !isChecked($input->{STRETCH})) ? "true" : "false"; + + + + $fillings->{TITLE} = $input->{TITLETEXT}; + $fillings->{YAXIS_LABEL} = $input->{YAXIS_LABEL}; + + $fillings->{XAXIS_LABEL} = $input->{XAXIS_LABEL}; + $fillings->{ERRBAR} = $input->{ERRBAR}; + $fillings->{SHOWINGBOX} = (isChecked($input->{SHOWINGBOX})) ? "s" : "n"; + $fillings->{SHRINKBOOLEAN} = ($fillings->{SHOWINGBOX} eq "s") ? "true" : "false"; + $fillings->{SHRINKFACTOR} = $input->{BOXSHRINK}; + + if ((defined $input->{CHARSPERLINE}) && + isInt($input->{CHARSPERLINE}) && + ($input->{CHARSPERLINE} > 0)) { + $fillings->{CHARSPERLINE} = $input->{CHARSPERLINE}; + } + + if (defined $input->{BARBITS}) { + $fillings->{BARBITS} = $input->{BARBITS}; + } else { + $fillings->{BARBITS} = ($fillings->{KIND} == $AA) ? 4.3 : 2; + } + + if (defined $input->{TICBITS}) { + $fillings->{TICBITS} = $input->{TICBITS}; + } else { + $fillings->{TICBITS} = 1; + } + + + + +# if (isChecked($input->{NOCOLOR})) { +# $fillings->{COLORSCHEME} = "b"; +# } else { +# $fillings->{COLORSCHEME} = ($kind == $AA) ? "a" : "n"; +# } + + #color + if (defined $input->{DEFAULT_COLOR}) { + $fillings->{DEFAULT_COLOR} = (isHexColor( $input->{DEFAULT_COLOR})) ? "c" . $input->{DEFAULT_COLOR} : + $input->{DEFAULT_COLOR}; + } + + if (isChecked($input->{SHOWENDS})) { + $fillings->{SHOWENDS} = ($fillings->{KIND} == $AA) ? "p" : "d"; + } else { + $fillings->{SHOWENDS} = "-"; + } + + $fillings->{DESC} = getDescription($desc_r, $fillings->{KIND}); + + $fillings->{ERRORBARFRACTION} = $input->{ERRORBARFRACTION}; + $fillings->{COLORSCHEME} = $input->{COLORSCHEME}; + $fillings->{COLORS} = $input->{COLORS}; +} + +sub getDescription { + my $returnVal = ""; + + foreach (@{$_[0]}) { + if(defined($_)) { + $returnVal .= "% * $_\n"; + } else { + $returnVal .= "% * \n"; + } + } + + if ($_[1] == $AA) { + $returnVal .= "% * PROTEIN ALIGNMENT"; + } else { + $returnVal .= "% * NUCLEOTIDE ALIGNMENT"; + } + + return $returnVal; +} + + +################################################################################ +##### SETTING DEFAULTS ##### +################################################################################ + +sub setDefaults { + my ($fillings, $defaults, $numchars) = @_; + + $fillings->{LOGOHEIGHT} = $defaults->{LOGOHEIGHT} if !defined $fillings->{LOGOHEIGHT}; + $fillings->{LOGOWIDTH} = $defaults->{LOGOWIDTH} if !defined $fillings->{LOGOWIDTH}; + + $fillings->{START_NUM} = $defaults->{START_NUM} if !defined $fillings->{START_NUM}; + $fillings->{LOGOSTART} = $fillings->{START_NUM} if !defined $fillings->{LOGOSTART}; + $fillings->{LOGOEND} = $numchars + $fillings->{LOGOSTART} - 1 if !defined $fillings->{LOGOEND}; + + $fillings->{YAXIS} = $defaults->{YAXIS} if !defined $fillings->{YAXIS}; + $fillings->{TITLE} = $defaults->{TITLE} if !defined $fillings->{TITLE} || $fillings->{TITLE} eq ""; + #$fillings->{YAXIS_LABEL} = $defaults->{YAXIS_LABEL} if !defined $fillings->{YAXIS_LABEL} || $fillings->{YAXIS_LABEL} eq ""; + $fillings->{YAXIS_LABEL} = $defaults->{YAXIS_LABEL} if !defined $fillings->{YAXIS_LABEL} ; + $fillings->{XAXIS_LABEL} = $defaults->{XAXIS_LABEL} if !defined $fillings->{XAXIS_LABEL} || $fillings->{XAXIS_LABEL} eq ""; + + $fillings->{BARENDS} = $defaults->{BARENDS} if !defined $fillings->{BARENDS}; + $fillings->{OUTLINE} = $defaults->{OUTLINE} if !defined $fillings->{OUTLINE}; + $fillings->{SHOWINGBOX} = $defaults->{SHOWINGBOX} if !defined $fillings->{SHOWINGBOX}; + $fillings->{NUMBERING} = $defaults->{NUMBERING} if !defined $fillings->{NUMBERING}; + + $fillings->{ERRORBARFRACTION} = $defaults->{ERRORBARFRACTION} if !defined $fillings->{ERRORBARFRACTION}; + $fillings->{SHRINKFACTOR} = $defaults->{SHRINKFACTOR} if !defined $fillings->{SHRINKFACTOR}; + $fillings->{ERRBAR} = $defaults->{ERRBAR} if !defined $fillings->{ERRBAR}; + +# printf("logostart = %d, start num = %d, numchars = $numchars, logoend = %d\n", $fillings->{LOGOSTART}, $fillings->{START_NUM}, +# $fillings->{LOGOEND}); + + my $givenrange = $fillings->{LOGOEND} - $fillings->{LOGOSTART} + 1; + my $possiblerange = $numchars - ($fillings->{LOGOSTART} - $fillings->{START_NUM}); + + if (!defined $fillings->{CHARSPERLINE} && ($givenrange > $possiblerange)) { + $fillings->{CHARSPERLINE} = $numchars - ($fillings->{LOGOSTART} - $fillings->{START_NUM}); + } elsif (!defined $fillings->{CHARSPERLINE}) { + $fillings->{CHARSPERLINE} = $fillings->{LOGOEND} - $fillings->{LOGOSTART} + 1; + } + + $fillings->{DEFAULT_COLOR} = $defaults->{DEFAULT_COLOR} if !defined $fillings->{DEFAULT_COLOR} || + $fillings->{DEFAULT_COLOR} eq ""; + +# printf("chars per line = %s\n",$fillings->{CHARSPERLINE}); +# print("givenrange = $givenrange, possiblerange = $possiblerange\n"); + + if ($givenrange > $possiblerange) { + $fillings->{LOGOLINES} = roundup($possiblerange / $fillings->{CHARSPERLINE}); + } else { + $fillings->{LOGOLINES} = roundup($givenrange / $fillings->{CHARSPERLINE}); + } + + $fillings->{CHARWIDTH} = ($fillings->{LOGOWIDTH} - 1.5) / $fillings->{CHARSPERLINE}; + +# # change height if more than 1 line +# $fillings->{LOGOHEIGHTPOINTS} = int($fillings->{LOGOHEIGHT} * (72 / 2.54)) * $fillings->{LOGOLINES}; + + # LOGOHEIGHTPOITNS is the height input by the user +# $fillings->{LOGOHEIGHTPOINTS} = int($fillings->{LOGOHEIGHT} * (72 / 2.54)); # user specifies height of entire logo + $fillings->{LOGOHEIGHTPOINTS} = int($fillings->{LOGOHEIGHT} * (72 / 2.54)) * $fillings->{LOGOLINES}; # user specifies height of logo line + $fillings->{LOGOWIDTHPOINTS} = int($fillings->{LOGOWIDTH} * (72 / 2.54)); + + # LOGOLINEHEIGHT is the height of each logo line, in cm +# $fillings->{LOGOLINEHEIGHT} = $fillings->{LOGOHEIGHT} / $fillings->{LOGOLINES}; # user specifies height of entire logo + $fillings->{LOGOLINEHEIGHT} = $fillings->{LOGOHEIGHT}; # user specifies height of logo line +} + +sub roundup { + return ($_[0] - int($_[0]) > 0) ? int($_[0] + 1) : $_[0]; +} + + +################################################################################ +##### COLORS ##### +################################################################################ + +sub getDefaultColors { + my ($defaults) = @_; + my $returnVal = ""; + $returnVal .= "/black " . $defaults->{black} . " def\n"; + $returnVal .= "/red " . $defaults->{red} . " def\n"; + $returnVal .= "/green " . $defaults->{green} . " def\n"; + $returnVal .= "/blue " . $defaults->{blue} . " def\n"; + $returnVal .= "/yellow " . $defaults->{yellow} . " def\n"; + $returnVal .= "/purple " . $defaults->{purple} . " def\n"; + $returnVal .= "/orange " . $defaults->{orange} . " def\n"; + + return $returnVal; +} + +sub getNAColors { + my $returnVal = <<END +% Standard DNA/RNA color scheme +/colorDict << + (G) orange + (T) red + (C) blue + (A) green + (U) red +END + ; + + return $returnVal; +} + +sub getAAColors { + my $returnVal = <<END +% Standard Amino Acid colors +/colorDict << + (G) green + (S) green + (T) green + (Y) green + (C) green + (N) purple + (Q) purple + (K) blue + (R) blue + (H) blue + (D) red + (E) red + (P) black + (A) black + (W) black + (F) black + (L) black + (I) black + (M) black + (V) black +END + ; + + return $returnVal; +} + +sub setColors { + my ($fillings, $defaults, $input) = @_; + my $colordef = getDefaultColors($defaults); + my $colordict = "/colorDict <<\n"; + + if ($fillings->{COLORSCHEME} eq "DEFAULT") { + $colordef = getDefaultColors($defaults); + + if ($fillings->{KIND} eq $AA) { + $colordict = getAAColors(); + } else { + $colordict = getNAColors(); + } + } elsif ($fillings->{COLORSCHEME} eq "BW") { + # do nothing for dict + } else { + + my %colorhash = %{ $fillings->{COLORS} }; + my $colorName = ""; + + foreach (keys %colorhash) { # keys are strings of residues, value = color name or color code (FF0000) + # add color to definitions + $colorName = $colorhash{$_}; + +# print("color = $_\n"); + + addColorDef(\$colordef, $colorName ) if (isHexColor($colorName)); + + # add have each residue use the color + foreach (split(//, $_)) { + # add color to dictionary + if (isHexColor($colorName)) { + $colordict .= " ($_) c$colorName\n" if !($_ =~ /^\s*$/); + } else { + $colordict .= " ($_) $colorName\n" if !($_ =~ /^\s*$/); + } + } + } + } + + $colordict .= "\n>> def"; + + # add to fillings + $fillings->{COLORDEF} = $colordef; + $fillings->{COLORDICT} = $colordict; +} + +sub addColorDef { +# print("adding to color def\n"); + my ($colordef_r, $color) = @_; + my $PSColor = getPSColor($color); + $$colordef_r .= "/c$color $PSColor def\n"; +} + +sub isHexColor { + return ($_[0] =~ /^[0-9a-fA-F]+$/) && (length $_[0] == 6); +} + +# know that it is hex color +sub getPSColor { + return "[" . hex(substr($_[0],0,2)) / 255 . " " . + hex(substr($_[0],2,2)) / 255 . " " . + hex(substr($_[0],4,2)) / 255 . "]"; +} + + +################################################################################ +##### SETTING DATA FIELD ##### +################################################################################ + +sub setData { + my ($fillings, $data_r) = @_; + + my @data = @$data_r; + my ($height, $letter); + my @slice; + my $data; + my $start_num = $fillings->{START_NUM}; + + my $start = $fillings->{LOGOSTART} - $start_num; # where in @data to start + my $end = $fillings->{LOGOEND} - $start_num; # where in @data to end + my $charsperline = $fillings->{CHARSPERLINE}; + + my $numlabel = $fillings->{LOGOSTART}; + + $end = ($end >= scalar @data) ? (scalar @data - 1) : $end; + + for (my $i=$start ; $i<=$end ; $i++) { + + # if add new lines +# if ((($i - $start) % $charsperline == 0) && +# ($i != $start) && # not first one +# ($i != $end)) { # not last one + if ((($i - $start) % $charsperline == 0) && + ($i != $start)) { # not first one + $data .= <<END +EndLine +StartLine + +END + ; + } + + @slice = @{$data[$i]}; + $data .= <<END +($numlabel) startstack +END + ; + + $numlabel++; + + foreach (@slice) { + ($letter,$height) = ($_ =~ /^(.{1})(\S+)/); + + # is space, so leave + if ($letter eq " ") { + last; + } + + # look for ">", which is symbol for error bar, then quit + if ($letter eq ">") { + last; + } + +# # look for negative heights +# if ($height < 0) { +# next; +# } + + $letter = (uc $letter); # always uppercase + $height = ($height < 0) ? 0 : $height; + $data .= " $height ($letter) numchar\n"; + } + + # put in error bars -- size is in $height as read in before + if ($fillings->{ERRBAR} && $letter ne " " && $height != 0) { + $data .= " $height Ibeam\n"; + } + + $data .= <<END +endstack + +END + ; + + } + + $fillings->{DATA} = $data; +} + +################################################################################ + +1;