#!/usr/bin/env perl # # Copyright (C) 2006-2012 Boris Veytsman & Leila Akhmadeeva # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program 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 # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # =pod =head1 NAME pedigree - create a TeX file for pedigree from a csv file =head1 SYNOPSIS B [-c I] [-d] [-o I] [-s I] I B -v =head1 DESCRIPTION The program converts a comma separated I into a TeX file with pst-pdgr macros. =head1 OPTIONS =over 4 =item B<-c> I The configuration file to read along with the system-wide and user's configuration files =item B<-d> Debug mode on =item B<-o> -I The ouput file instead of I =item B<-s> -I If this option is selected, the pedigree is constructed starting from the node with the Id i. Otherwise it is started from the proband node. This option allows to create pedigrees with multiple probands or absent probands, or show people who are not proband's relatives. =item B<-v> Print version information =back =head1 FILES =over 4 =item B Global configuration file =item B<$HOME/.pedigreerc> User configuration file =back =head1 SEE ALSO The manual distributed with this program describes the format of the configuration file and the input file. The library functions are described in Pedigree::Language(3), Pedigree::Parser(3), Pedigree::Node(3), Pedigree::PersonNode(3), Pedigree::MarriageNode(3), Pedigree::Area(3). =head1 AUTHOR Boris Veytsman, Leila Akhmadeeva, 2006-2012 =cut ######################################################### # Packages and Options # ######################################################### use strict; use vars qw($opt_c $opt_d $opt_o $opt_s $opt_v); our $TLCONF; # TL config file our $TLCONFLOCAL; # TL local config file BEGIN { # find files relative to our installed location within TeX Live chomp(my $TLMaster = `kpsewhich -var-value=SELFAUTOPARENT`); # TL root if (length($TLMaster)) { unshift @INC, "$TLMaster/texmf-dist/scripts/pedigree-perl"; $TLCONF = "$TLMaster/texmf-config/pedigree/pedigree.cfg"; chomp($TLCONFLOCAL = `kpsewhich -var-value=TEXMFLOCAL`); $TLCONFLOCAL .= "/pedigree/pedigree.cfg"; } } use Getopt::Std; use FileHandle; use Pedigree; ######################################################### # Options Reading and Global Variables # ######################################################### my $USAGE="Usage: $0 [-c configuration_file] [-d] [-o output_file] [-s start_id] input_file\n"; my $COPYRIGHT=<fdopen(fileno(STDIN),"r"); } else { $IN->open($ARGV[0], "r") or die "Cannot read from $ARGV[0]\n"; } my $outfile=$ARGV[0]; if ($opt_o) { $outfile = $opt_o; } else { $outfile =~ s/\.[^\.]*$/.tex/; } if ($outfile eq '-') { $OUT->fdopen(fileno(STDOUT),"w"); } else { $OUT->open($outfile, "w") or die "Cannot write to $outfile\n"; } ######################################################### # Configuration # ######################################################### # # First, the defaults. Even if we do not find any # configuration file, these will work. # # # Do we want to have a full LaTeX file or just a fragment? # our $fulldoc=1; # # What kind of document do we want # # our $documentheader='\documentclass[landscape]{article}'; our $documentheader='\documentclass{article}'; # # Define additional packages here # # our $addtopreamble=<; my $parser = new Pedigree::Parser($_,$lang); my $start; ######################################################### # Reading input # ######################################################### while (<$IN>) { my $node = Pedigree->MakeNode($parser->Parse($_)); if (ref($node)) { if ($start_id) { if ($start_id eq $node->Id()) { $start = $node; if ($DEBUG) { print STDERR "Found start: ", $start->Id(), "\n"; } } } else { if ($node->isProband()) { if (ref($start)) { print STDERR "Two probands? I got ", $start->Id(), " and ", $node->Id(), "\n"; } $start=$node; if ($DEBUG) { print STDERR "Found proband: ", $start->Id(), "\n"; } } } } } if (!ref($start)) { die "Cannot find the start!\n"; } ######################################################### # Process Pedigree # ######################################################### # # Check all parents # $start->CheckAllParents(); # # The root is the root of the tree to which the proband # belongs # my ($root, undef)=@{$start->FindRoot(0)}; if ($DEBUG) { print STDERR "Root: ", $root->Id(), "\n"; } # # Calculate relative coordinates # $root->SetRelX(0); $root->SetRelY(0); $root->SetArea(); # # Calculate the absolute coordinates # $root->CalcAbsCoor(0,0); # # Check for consanguinic marriages # $root->AddConsanguinicMarriages(); # # And twins # $root->AddTwins($ydist); # # Get the frame # my ($xmin, $ymin, $xmax, $ymax) = @{$root->SetFrame($xdist, $ydist)}; ######################################################### # Printing headers # ######################################################### if ($fulldoc) { printheader($OUT,$lang,$addtopreamble); } ######################################################### # Calculate scale and check whether to rotate # ######################################################### my $scale=1; my $scaleRotated = 1; if ($maxH && $maxW) { if ($maxH/($ymax-$ymin) < $scale) { $scale = $maxH/($ymax-$ymin); } if ($maxW/($xmax-$xmin) < $scale) { $scale = $maxW/($xmax-$xmin); } if ($maxW/($ymax-$ymin) < $scaleRotated) { $scaleRotated = $maxW/($ymax-$ymin); } if ($maxH/($xmax-$xmin) < $scaleRotated) { $scaleRotated = $maxH/($xmax-$xmin); } } my $doRotate = ($rotate =~ /yes/i) || (($rotate =~ /maybe/i) && ($scaleRotated > $scale)); ######################################################### # Printing pspicture # ######################################################### my $pre; my $post ='}'."\n"; if ($doRotate) { $descarmA *= $scaleRotated; $pre="\\rotatebox{90}{%\n\\psset{descarmA=$descarmA}%\n"; if ($scaleRotated<1) { $pre .= '\psset{unit='.$scaleRotated.'}%'."\n"; } } else { $descarmA *= $scale; $pre="{%\n\\psset{descarmA=$descarmA}%\n"; if ($scale<1) { $pre .= '{\psset{unit='.$scale.'}%'."\n"; } } print $OUT $pre; print $OUT '\begin{pspicture}',"($xmin,$ymin)($xmax,$ymax)\n"; print $OUT $root->DrawAll($xdist, $ydist, $belowtextfont, $abovetextfont, @fieldsforchart); print $OUT '\end{pspicture}%',"\n"; print $OUT $post; ######################################################### # Printing legend # ######################################################### if ($printlegend) { print $OUT $root->PrintAllLegends($lang, @fieldsforlegend); } ######################################################### # Printing end # ######################################################### if ($fulldoc) { printend($OUT); } ######################################################### # Exiting # ######################################################### exit 0; ######################################################### # Subroutines # ######################################################### # # Printing headers & footers # sub printheader { my ($OUT,$lang,$addtopreamble)=@_; print $OUT <Header; print $OUT <