User Tools

Site Tools


neuroimagen:neuro4.pm

This is an old revision of the document!


NEURO4.pm

<code perl NEURO4.pm> #!/usr/bin/perl

# Copyright 2019 O. Sotolongo asqwerty@gmail.com

# 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. # use strict; use warnings; package NEURO4; require Exporter; use File::Slurp qw(read_file); use File::Find::Rule; use Mail::Sender; use MIME::Lite; use File::Basename qw(basename);

our @ISA = qw(Exporter); our @EXPORT = qw(print_help load_project cut_shit); our @EXPORT_OK = qw(print_help escape_name trim check_or_make load_project populate get_subjects check_subj check_fs_subj get_list shit_donei get_pair cut_shit); our %EXPORT_TAGS = (all ⇒ [qw(print_help escape_name trim check_or_make load_project check_subj check_fs_subj get_lut run_dckey dclokey centiloid_fbb populate get_subjects get_list shit_done get_pair cut_shit)],

                                      usual => [qw(print_help load_project check_or_make cut_shit)],);

our $VERSION = 1.0;

sub print_help { # just print the help

      my $hlp = shift;
      open HELP, "<$hlp";
      while(<HELP>){
              print;
      }
      close HELP;
      return;

}

sub escape_name { # in order to escape directory names with a lot of strange symbols

      my $name = shift;
      $name=~s/\ /\\\ /g;
      $name=~s/\`/\\\`/g;
      $name=~s/\(/\\\(/g;
      $name=~s/\)/\\\)/g;
      return $name;

}

sub trim {

      my $string = shift;
      $string =~ s/^\s+//;  #trim leading space
      $string =~ s/\s+$//;  #trim trailing space
      return $string;

}

sub check_or_make {

      my $place = shift;
      # I must check if directory exist, else I create it.
      if(opendir(TEST, $place)){
      closedir TEST;
      }else{
              mkdir $place;
      }

}

sub load_project {

      my $study = shift;
      my %stdenv = map {/(.*) = (.*)/; $1=>$2 } read_file $ENV{HOME}."/.config/neuro/".$study.".cfg";
      return %stdenv;

}

sub check_subj {

      my $proj_path = shift;
      my $subj = shift;
      my %mri = ('T1w' => 0, 'T2w' => 0, 'dwi' => 0, 'dwi_sbref' => 0);
      my $subj_dir = $proj_path.'/bids/sub-'.$subj.'/anat';
      if( -e $subj_dir && -d $subj_dir){
              my @t1 = find(file => 'name' => "sub-$subj*_T1w.nii.gz", in =>  $subj_dir);
              if (-e $t1[0] && -f $t1[0]){
                      $mri{'T1w'} = $t1[0];
              }
              my @t2 = find(file => 'name' => "sub-$subj*_T2w.nii.gz", in =>  $subj_dir);
              if (-e $t2[0] && -f $t2[0]){
                      $mri{'T2w'} = $t2[0];
              }
      }
      $subj_dir = $proj_path.'/bids/sub-'.$subj.'/dwi';
      if( -e $subj_dir && -d $subj_dir){
              my @dwi_sbref = find(file => 'name' => "sub-$subj*_sbref_dwi.nii.gz", in =>  $subj_dir);
              if (-e $dwi_sbref[0] && -f $dwi_sbref[0]){
                      $mri{'dwi_sbref'} = $dwi_sbref[0];
              }
              my @dwi = find(file => 'name' => "sub-$subj*_dwi.bval", in =>  $subj_dir);
              if (-e $dwi[0] && -f $dwi[0]){
                      ($mri{'dwi'} = $dwi[0]) =~ s/bval$/nii\.gz/;
              }
      }
      return %mri;

}

sub check_fs_subj {

      my $subj = shift;
      my $subj_dir = qx/echo \$SUBJECTS_DIR/;
      chomp($subj_dir);
      my $place = $subj_dir."/".$subj;
      my $ok = 0;
      # I must check if directory exist.
      if( -e $place && -d $place){$ok = 1;}
      return $ok;

}

sub get_lut {

      my $ifile = shift;
      my $patt = '\s*(\d{1,8})\s*([A-Z,a-z,\-,\_,\.,0-9]*)\s*.*';
      my %aseg_data = map {/$patt/; $1=>$2} grep {/^$patt/} read_file $ifile;
      return %aseg_data;

}

sub run_dckey{

      my @props = @_;
      my $order = "dckey -k $props[1] $props[0] 2\>\&1";
      print "$order\n";
      my $dckey = qx/$order/;
      chomp($dckey);
      $dckey =~ s/\s*//g;
      return $dckey;

}

sub dclokey{

      my @props = @_;
      my $order = "dcdump $props[0] 2\>\&1 \| grep \"".$props[1]."\"";
      print "$order\n";
      my $line = qx/$order/;
      (my $dckey) = $line =~ /.*VR=<\w{2}>\s*VL=<0x\d{3,4}[a-z]*>\s*<(.*)\s*>/;
      if($dckey){
              $dckey =~ s/\s*//g;
      }
      return $dckey;

}

sub centiloid_fbb {

  my $suvr = shift;
  return 153.4*$suvr-154.9;

}

sub populate {

      my $patt = shift;
      my $csv = shift;
      my %pdata = map { /^$patt$/; $1 => $2} grep {/^$patt$/} read_file $csv;
      return %pdata;

}

sub get_subjects {

      my $db = shift;
      my @slist = map {/^(\d{4});.*$/; $1} grep { /^\d{4}/ } read_file($db, chomp => 1);
      return @slist;

}

sub get_list {

      my $ifile = shift;
      my @slist = map {/^(\d{4}).*$/; $1} grep { /^\d{4}/ }read_file($ifile, chomp => 1);
      return @slist;

}

sub get_pair {

      my $ifile = shift;
      my %pet_data = map {/(.*);(.*)/; $1=>$2} read_file $ifile;
      return %pet_data;

}

sub shit_done {

      my @adv = @_;
      my $msg = MIME::Lite->new(
              From    => "$ENV{'USER'}\@detritus.fundacioace.com",
              To      => "$ENV{'USER'}\@detritus.fundacioace.com",
              Subject => 'Script terminado',
              Type    => 'multipart/mixed',
      );
      $msg->attach(
              Type     => 'TEXT',
              Data     => "$adv[0] ha terminado en el estudio $adv[1].\n\n",
      );
      $msg->attach(
              Type     => 'application/gzip',
              Path     => $adv[2],
              Filename => basename($adv[2]),
      );
      $msg->send;

}

sub cut_shit {

      my $db = shift;
      my $cfile = shift;
      my @plist = get_subjects($db);
      my @oklist;
      if (-e $cfile){
              my @cuts = get_list($cfile);
              foreach my $cut (sort @cuts){
                      if(grep {/$cut/} @plist){
                              push @oklist, $cut;
                      }
              }
      }else{
              @oklist = @plist;
      }

return @oklist; }

<code>

neuroimagen/neuro4.pm.1575880632.txt.gz · Last modified: 2020/08/04 10:47 (external edit)