Display Purdy notation for desired level of pedigree string in stock view

[noahddewitt]

Expected Behavior

Purdy pedigree is a notation system for describing pedigree trees that can vary in detail/length based on the amount of pedigree data available and the generation level desired. At the moment, in the accession view a pedigree string is generated that's similar to but not quite a Purdy pedigree string. At the base level it displays correctly when data on both parents is available:

At higher levels, it displays Purdy-like strings with NAs for that desired level:

In the example here, string " NA/NA//NA/NA///FR-81-19/FL-302//FL-302/IN-71761-A-3-31-5-48" should be "Jamestown/3/FR-81-19/FL-302//FL-302/IN-71761-A-3-31-5-48".

Two desired changes should be a) after going from "/" to "//", lower branches in trees with more levels increment upwards by numbers instead of adding slashes (so "/3/" instead of "///", "/4/" instead of "////", etc) and b) instead of displaying NAs, the highest-level for which data is available should be displayed (so for "A/B" where A's pedigree is "C/D" and B's pedigree is unknown, a "Grandparent" pedigree should look like "C/D//B".

As something else to consider for a potential toggleable option, wheat breeders often use a modified version of Purdy notation that also displays information on the intervening generations. This can get messy quickly but can be useful to see all the information at once and is more straightforward to generate algorithmically than Purdy notation! In the above example, "Jamestown/3/FR-81-19/FL-302//FL-302/IN-71761-A-3-31-5-48" would go to "Jamestown/AGS 2060 [IC 855 (FR-81-19/FL-302) / Coker 9663 (FL-302/IN-71761-A-3-31-5-48)]".

There are definitely more elegant ways of getting this recursively but here is a quick attempt I made at modifying the code in "sgn/lib/SGN/Controller/AJAX/Stock.pm" to show approximately what I'm thinking of. I don't know how useful it will be since I don't know much Perl!

Change:

sub get_pedigree_string {
    my ($self, $level) = @_;

    my $pedigree_hashref = $self->get_ancestor_hash();

    #print STDERR "Getting string of level $level from pedigree hashref ".Dumper($pedigree_hashref)."\n";
    if ($level eq "Parents") {
        return $self->_get_parent_string($pedigree_hashref);
    }
    elsif ($level eq "Grandparents") {
        my $maternal_parent_string = $self->_get_parent_string($pedigree_hashref->{'female_parent'});
        my $paternal_parent_string = $self->_get_parent_string($pedigree_hashref->{'male_parent'});
        return "$maternal_parent_string//$paternal_parent_string";
    }
    elsif ($level eq "Great-Grandparents") {
        my $mm_parent_string = $self->_get_parent_string($pedigree_hashref->{'female_parent'}->{'female_parent'});
        my $mf_parent_string = $self->_get_parent_string($pedigree_hashref->{'female_parent'}->{'male_parent'});
        my $pm_parent_string = $self->_get_parent_string($pedigree_hashref->{'male_parent'}->{'female_parent'});
        my $pf_parent_string = $self->_get_parent_string($pedigree_hashref->{'male_parent'}->{'male_parent'});
        return "$mm_parent_string//$mf_parent_string///$pm_parent_string//$pf_parent_string";
    }
}

sub _get_parent_string {
    my ($self, $pedigree_hashref) = @_;
    my $mother = $pedigree_hashref->{'female_parent'}->{'name'} || 'NA';
    my $father = $pedigree_hashref->{'male_parent'}->{'name'} || 'NA';
    return "$mother/$father";
}

To something like:

sub get_pedigree_string {
    my ($self, $level) = @_;

    my $pedigree_hashref = $self->get_ancestor_hash();

    #print STDERR "Getting string of level $level from pedigree hashref ".Dumper($pedigree_hashref)."\n";
    if ($level eq "Parents") {
        return $self->_get_parent_string($pedigree_hashref);
    }
    elsif ($level eq "Grandparents") {
        my $maternal_parent_string = $self->_get_parent_string($pedigree_hashref->{'female_parent'});
        my $paternal_parent_string = $self->_get_parent_string($pedigree_hashref->{'male_parent'});
            
        #If neither parent has pedigree info, root symbol single should be single slash
        if ($maternal_parent_string =~ "\/" || $paternal_parent_string =~ "\/") {
            return "$maternal_parent_string//$paternal_parent_string";
        } else { 
            return "$maternal_parent_string/$paternal_parent_string";     
        }
    }
    elsif ($level eq "Great-Grandparents") {
        my $mm_parent_string = $self->_get_parent_string($pedigree_hashref->{'female_parent'}->{'female_parent'});
        my $mf_parent_string = $self->_get_parent_string($pedigree_hashref->{'female_parent'}->{'male_parent'});
        my $pm_parent_string = $self->_get_parent_string($pedigree_hashref->{'male_parent'}->{'female_parent'});
        my $pf_parent_string = $self->_get_parent_string($pedigree_hashref->{'male_parent'}->{'male_parent'});
            
        #If none of grandparents have ped, return sub-string, or NAs if parent ped missing
        if ($mm_parent_string !~ "\/" && $mf_parent_string !~ "\/" && $pm_parent_string !~ "\/" && $pf_parent_string !~ "\/") {
                return "$mm_parent_string/$mf_parent_string//$pm_parent_string/$pf_parent_string";
        } elsif ($mm_parent_string !~ "\/" && $mf_parent_string !~ "\/") {
            return "$mm_parent_string/$mf_parent_string/3/$pm_parent_string//$pf_parent_string"
        } elsif ($pm_parent_string !~ "\/" && $pf_parent_string !~ "\/") {
            return "$mm_parent_string//$mf_parent_string/3/$pm_parent_string/$pf_parent_string" 
        } else {
            return "$mm_parent_string//$mf_parent_string/3/$pm_parent_string//$pf_parent_string";
        }       
    }
}

sub _get_parent_string {
    my ($self, $pedigree_hashref) = @_;
    my $mother = $pedigree_hashref->{'female_parent'}->{'name'} || 'NA';
    my $father = $pedigree_hashref->{'male_parent'}->{'name'} || 'NA';
        
    #If parent has no pedigree info, return parent name
    if ($mother eq 'NA' && $father eq 'NA') {
        return $self->{'name'}
    } else {
        return "$mother/$father";
    }
}

For Bugs:

Environment

Steps to Reproduce

[lukasmueller]

Great feedback, thanks! :-) We will look at it in the next labmeeting.