<commit_before>#!/usr/bin/env perl


=head1 NAME

 FixGenotypeStorageDosage

=head1 SYNOPSIS

mx-run FixGenotypeStorageDosage [options] -H hostname -D dbname -u username [-F]

this is a subclass of L<CXGN::Metadata::Dbpatch>
see the perldoc of parent class for more details.

=head1 DESCRIPTION
This patch fixes the genotype storage error of loading DS=0 when the GT is infact unknown (e.g. GT='./.'). DS is now stored as 'NA' in these cases.
This subclass uses L<Moose>. The parent class uses L<MooseX::Runnable>

=head1 AUTHOR


=head1 COPYRIGHT & LICENSE

Copyright 2010 <NAME> Institute for Plant Research

This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut


package FixGenotypeStorageDosage;

use Moose;
use Bio::Chado::Schema;
use CXGN::People::Schema;
use Try::Tiny;
use CXGN::Genotype::Search;
use JSON;
extends 'CXGN::Metadata::Dbpatch';


has '+description' => ( default => <<'' );
This patch fixes the genotype storage error of loading DS=0 when the GT is infact unknown (e.g. GT='./.'). DS is now stored as 'NA' in these cases.

has '+prereq' => (
	default => sub {
        [],
    },

);

sub patch {
    my $self=shift;

    print STDOUT "Executing the patch:\n " .   $self->name . ".\n\nDescription:\n  ".  $self->description . ".\n\nExecuted by:\n " .  $self->username . " .";

    print STDOUT "\nChecking if this db_patch was executed before or if previous db_patches have been executed.\n";

    print STDOUT "\nExecuting the SQL commands.\n";
    my $schema = Bio::Chado::Schema->connect( sub { $self->dbh->clone } );
    my $people_schema = CXGN::People::Schema->connect( sub { $self->dbh->clone } );

    my $update_q = "UPDATE genotypeprop SET value = ? WHERE genotypeprop_id = ?;";
    my $h_update = $schema->storage->dbh()->prepare($update_q);

    # Restricting search to "NEW" genotyping protocols which have nd_protocolprop information. Old genotyping protocols only had the DS value and shuold be assumed to be stored correctly.
    my $q = "SELECT nd_protocol_id FROM nd_protocol JOIN nd_protocolprop USING(nd_protocol_id) ORDER BY nd_protocol_id ASC;";
    my $h = $schema->storage->dbh()->prepare($q);
    $h->execute();
    while (my ($protocol_id) = $h->fetchrow_array()) {
        my $genotypes_search = CXGN::Genotype::Search->new({
            bcs_schema=>$schema,
            people_schema=>$people_schema,
            protocol_id_list=>[$protocol_id],
            protocolprop_top_key_select=>[],
            protocolprop_marker_hash_select=>[]
        });
        $genotypes_search->init_genotype_iterator();
        while (my ($count, $genotype_data) = $genotypes_search->get_next_genotype_info) {
            #my $m_hash = $genotype_data->{selected_protocol_hash}->{markers};
            my $g_hash = $genotype_data->{selected_genotype_hash};

            while (my ($k, $v) = each %$g_hash) {
                if ($v->{GT} eq './.' || $v->{GT} eq '.|.' || $v->{GT} eq '././.' || $v->{GT} eq '.|.|.' || $v->{GT} eq './././.' || $v->{GT} eq '.|.|.|.') {
                    $v->{DS} = 'NA';
                    $v->{NT} = '';
                }
            }

            my $genotypeprop_id = $genotype_data->{markerProfileDbId};
            print STDERR "CHECKING genotypeprop_id $genotypeprop_id\n";
            $h_update->execute(encode_json($g_hash), $genotypeprop_id);
        }
    }
<commit_msg>restrict to genotyping protocols<commit_after>#!/usr/bin/env perl


=head1 NAME

 FixGenotypeStorageDosage

=head1 SYNOPSIS

mx-run FixGenotypeStorageDosage [options] -H hostname -D dbname -u username [-F]

this is a subclass of L<CXGN::Metadata::Dbpatch>
see the perldoc of parent class for more details.

=head1 DESCRIPTION
This patch fixes the genotype storage error of loading DS=0 when the GT is infact unknown (e.g. GT='./.'). DS is now stored as 'NA' in these cases.
This subclass uses L<Moose>. The parent class uses L<MooseX::Runnable>

=head1 AUTHOR


=head1 COPYRIGHT & LICENSE

Copyright 2010 <NAME> Institute for Plant Research

This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut


package FixGenotypeStorageDosage;

use Moose;
use Bio::Chado::Schema;
use CXGN::People::Schema;
use Try::Tiny;
use CXGN::Genotype::Search;
use JSON;
extends 'CXGN::Metadata::Dbpatch';


has '+description' => ( default => <<'' );
This patch fixes the genotype storage error of loading DS=0 when the GT is infact unknown (e.g. GT='./.'). DS is now stored as 'NA' in these cases.

has '+prereq' => (
	default => sub {
        [],
    },

);

sub patch {
    my $self=shift;

    print STDOUT "Executing the patch:\n " .   $self->name . ".\n\nDescription:\n  ".  $self->description . ".\n\nExecuted by:\n " .  $self->username . " .";

    print STDOUT "\nChecking if this db_patch was executed before or if previous db_patches have been executed.\n";

    print STDOUT "\nExecuting the SQL commands.\n";
    my $schema = Bio::Chado::Schema->connect( sub { $self->dbh->clone } );
    my $people_schema = CXGN::People::Schema->connect( sub { $self->dbh->clone } );

    my $update_q = "UPDATE genotypeprop SET value = ? WHERE genotypeprop_id = ?;";
    my $h_update = $schema->storage->dbh()->prepare($update_q);

    # Restricting search to "NEW" genotyping protocols which have nd_protocolprop information. Old genotyping protocols only had the DS value and shuold be assumed to be stored correctly.
    my $geno_cvterm_id = SGN::Model::Cvterm->get_cvterm_row($schema, 'genotyping_experiment', 'experiment_type')->cvterm_id();
    my $q = "SELECT nd_protocol_id FROM nd_protocol JOIN nd_protocolprop USING(nd_protocol_id) WHERE nd_protocol.type_id=$geno_cvterm_id ORDER BY nd_protocol_id ASC;";
    my $h = $schema->storage->dbh()->prepare($q);
    $h->execute();
    while (my ($protocol_id) = $h->fetchrow_array()) {
        my $genotypes_search = CXGN::Genotype::Search->new({
            bcs_schema=>$schema,
            people_schema=>$people_schema,
            protocol_id_list=>[$protocol_id],
            protocolprop_top_key_select=>[],
            protocolprop_marker_hash_select=>[]
        });
        $genotypes_search->init_genotype_iterator();
        while (my ($count, $genotype_data) = $genotypes_search->get_next_genotype_info) {
            #my $m_hash = $genotype_data->{selected_protocol_hash}->{markers};
            my $g_hash = $genotype_data->{selected_genotype_hash};

            while (my ($k, $v) = each %$g_hash) {
                if ($v->{GT} eq './.' || $v->{GT} eq '.|.' || $v->{GT} eq '././.' || $v->{GT} eq '.|.|.' || $v->{GT} eq './././.' || $v->{GT} eq '.|.|.|.') {
                    $v->{DS} = 'NA';
                    $v->{NT} = '';
                }
            }

            my $genotypeprop_id = $genotype_data->{markerProfileDbId};
            print STDERR "CHECKING genotypeprop_id $genotypeprop_id\n";
            $h_update->execute(encode_json($g_hash), $genotypeprop_id);
        }
    }

{'fraction_non_alphanumeric': 0.14862935465448315, 'fraction_numerical': 0.0031410622501427754, 'mean_word_length': 3.0893169877408058, 'pattern_counts': {'":': 0, '<': 15, '<?xml version=': 0, '>': 97, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3294331', 'n_tokens_mistral': 2375, 'n_tokens_neox': 2250, 'n_words': 628}