User Tools

Site Tools


neuroimagen:neuro4.pm

Modulos del pipeline

Esta pagina es solo de referencia de los modulos Perl que dan soporte al pipeline de neuroimagen.

NEURO4.pm

Subrutinas:

  • sub print_help → Imprime la ayuda de un script, tomandola del directorio docs
  • sub escape_name → Escapa caracteres molestos de los nombres de directorio
  • sub trim → Elimina espacios, antes y despues de un string
  • sub check_or_make → crea un directorio si no existe
  • sub load_project → lee las variables de un proyecto dentro de un hash
  • sub check_subj → lee la estructura BIDS de un sujeto dentro de un hash
  • sub check_fs_subj → comprueba que un sujeto se haya procesado en FS
  • sub get_lut →
  • sub run_dckey → corre dckey sobre un DICOM y saca el valor de un tag
  • sub dclokey → devuelve el valor de un tag oculto en un DICOM
  • sub centiloid_fbb → devuelve el valor de Centiloide para un valor de SUVR en FBB
  • sub populate → Lee un archivo de CSV (o texto plano) y devuelve un hash con los valores, segun el patron que se suministra
  • sub get_subjects → Devuelve un array con los sujetos de un proyecto contenidos en un archivo de DB del proyecto
  • sub get_list → Devuelve un array con los sujetos de un proyecto contenidos, ignora el formato posterior a los primero 4 numeros
  • sub get_pair → devuelve un hash que contiene una DB de proyecto
  • sub shit_done → Envia un email con un archivo comprimido de attachment
  • sub cut_shit → Tomando como argumentos la DB de un proyecto y una lista simple de sujetos, devuelve un array con los sujetos de la lista incluidos en el proyecto.
NEURO4.pm
#!/usr/bin/perl
 
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 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;
}
 
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;
}

FSMetrics.pm

  • fs_file_metrics → devuelve las ordenes que se ejecutaran en la extraccion de las metricas de FS
FSMetrics.pm
#!/usr/bin/perl
 
use strict; use warnings;
package FSMetrics;
require Exporter;
our @ISA                = qw(Exporter);
our @EXPORT             = qw(fs_file_metrics);
our @EXPORT_OK  = qw(fs_file_metrics);
our %EXPORT_TAGS        = (all => [qw(fs_file_metrics)], usual => [qw(fs_file_metrics)],);
our $VERSION    = 0.1
;
sub fs_file_metrics {
my %stats = ('wmparc_stats' => {
                'order' => "asegstats2table --subjects <list> --meas volume --skip --statsfile wmparc.stats --all-segs --tablefile <fs_output>/wmparc_stats.txt",
                'active' => 1,
        },
        'aseg_stats' => {
                'order' => "asegstats2table --subjects <list> --meas volume --skip --tablefile <fs_output>/aseg_stats.txt",
                'active' => 1,
        },
        'aparc_volume_lh' => {
                'order' => "aparcstats2table --subjects <list> --hemi lh --meas volume --skip --tablefile <fs_output>/aparc_volume_lh.txt",
                'active' => 1,
        },
        'aparc_thickness_lh' => {
                'order' => "aparcstats2table --subjects <list> --hemi lh --meas thickness --skip --tablefile <fs_output>/aparc_thickness_lh.txt",
                'active' => 1,
        },
        'aparc_area_lh' => {
                'order' => "aparcstats2table --subjects <list> --hemi lh --meas area --skip --tablefile <fs_output>/aparc_area_lh.txt",
                'active' => 1,
        },
        'aparc_meancurv_lh' => {
                'order' => "aparcstats2table --subjects <list> --hemi lh --meas meancurv --skip --tablefile <fs_output>/aparc_meancurv_lh.txt",
        },
        'aparc_volume_rh' => {
                'order' => "aparcstats2table --subjects <list> --hemi rh --meas volume --skip --tablefile <fs_output>/aparc_volume_rh.txt",
                'active' => 1,
        },
        'aparc_thickness_rh' => {
                'order' => "aparcstats2table --subjects <list> --hemi rh --meas thickness --skip --tablefile <fs_output>/aparc_thickness_rh.txt",
                'active' => 1,
        },
        'aparc_area_rh' => {
                'order' => "aparcstats2table --subjects <list> --hemi rh --meas area --skip --tablefile <fs_output>/aparc_area_rh.txt",
                'active' => 1,
        },
        'aparc_meancurv_rh' => {
                'order' => "aparcstats2table --subjects <list> --hemi rh --meas meancurv --skip --tablefile <fs_output>/aparc_meancurv_rh.txt",
        },
        'lh.a2009s.volume' => {
                'order' => "aparcstats2table --hemi lh --subjects <list> --parc aparc.a2009s --meas volume --skip -t <fs_output>/lh.a2009s.volume.txt",
        },
        'lh.a2009s.thickness' => {
                'order' => "aparcstats2table --hemi lh --subjects <list> --parc aparc.a2009s --meas thickness --skip -t <fs_output>/lh.a2009s.thickness.txt",
        },
        'lh.a2009s.area' => {
                'order' => "aparcstats2table --hemi lh --subjects <list> --parc aparc.a2009s --meas area --skip -t <fs_output>/lh.a2009s.area.txt",
        },
        'lh.a2009s.meancurv' => {
                'order' => "aparcstats2table --hemi lh --subjects <list> --parc aparc.a2009s --meas meancurv --skip -t <fs_output>/lh.a2009s.meancurv.txt",
        },
        'rh.a2009s.volume' => {
                'order' => "aparcstats2table --hemi rh --subjects <list> --parc aparc.a2009s --meas volume --skip -t <fs_output>/rh.a2009s.volume.txt",
        },
        'rh.a2009s.thickness' => {
                'order' => "aparcstats2table --hemi rh --subjects <list> --parc aparc.a2009s --meas thickness --skip -t <fs_output>/rh.a2009s.thickness.txt",
        },
        'rh.a2009s.area' => {
                'order' => "aparcstats2table --hemi rh --subjects <list> --parc aparc.a2009s --meas area --skip -t <fs_output>/rh.a2009s.area.txt",
        },
        'rh.a2009s.meancurv' => {
                'order' => "aparcstats2table --hemi rh --subjects <list> --parc aparc.a2009s --meas meancurv --skip -t <fs_output>/rh.a2009s.meancurv.txt",
        },
        'lh.BA.volume' => {
                'order' => "aparcstats2table --hemi lh --subjects <list> --parc BA --meas volume --skip -t <fs_output>/lh.BA.volume.txt",
        },
        'lh.BA.thickness' => {
                'order' => "aparcstats2table --hemi lh --subjects <list> --parc BA --meas thickness --skip -t <fs_output>/lh.BA.thickness.txt",
        },
        'lh.BA.area' => {
                'order' => "aparcstats2table --hemi lh --subjects <list> --parc BA --meas area --skip -t <fs_output>/lh.BA.area.txt",
        },
        'lh.BA.meancurv' => {
                'order' => "aparcstats2table --hemi lh --subjects <list> --parc BA --meas meancurv --skip -t <fs_output>/lh.BA.meancurv.txt",
        },
        'rh.BA.volume' => {
                'order' => "aparcstats2table --hemi rh --subjects <list> --parc BA --meas volume --skip -t <fs_output>/rh.BA.volume.txt",
        },
        'rh.BA.thickness' => {
                'order' => "aparcstats2table --hemi rh --subjects <list> --parc BA --meas thickness --skip -t <fs_output>/rh.BA.thickness.txt",
        },
       'lh.BA.area' => {
                'order' => "aparcstats2table --hemi lh --subjects <list> --parc BA --meas area --skip -t <fs_output>/lh.BA.area.txt",
        },
        'lh.BA.meancurv' => {
                'order' => "aparcstats2table --hemi lh --subjects <list> --parc BA --meas meancurv --skip -t <fs_output>/lh.BA.meancurv.txt",
        },
        'rh.BA.volume' => {
                'order' => "aparcstats2table --hemi rh --subjects <list> --parc BA --meas volume --skip -t <fs_output>/rh.BA.volume.txt",
        },
        'rh.BA.thickness' => {
                'order' => "aparcstats2table --hemi rh --subjects <list> --parc BA --meas thickness --skip -t <fs_output>/rh.BA.thickness.txt",
        },
        'rh.BA.area' => {
                'order' => "aparcstats2table --hemi rh --subjects <list> --parc BA --meas area --skip -t <fs_output>/rh.BA.area.txt",
        },
        'rh.BA.meancurv' => {
                'order' => "aparcstats2table --hemi rh --subjects <list> --parc BA --meas meancurv --skip -t <fs_output>/rh.BA.meancurv.txt",
        },
);
return %stats;
}

send2slurm → envia un sbatch descrito en el hash de input

SLURM.pm

SLURM.pm
#!/usr/bin/perl
 
# Copyright 2021 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 SLURM;
require Exporter;
 
our @ISA = qw(Exporter);
our @EXPORT = qw(send2slurm);
our @EXPORT_OK = qw(send2slurm);
our %EXPORT_TAGS =(all => qw(send2slurm), usual => qw(send2slurm));
 
our $VERSION = 0.1;
 
sub define_task{
# default values for any task
	my %task;
	$task{'mem_per_cpu'} = '4G';
	$task{'cpus'} = 1;
	$task{'time'} = '2:0:0';
	my $label = sprintf("%03d", rand(1000));
	$task{'filename'} = 'slurm_'.$label.'.sh';
	$task{'output'} = 'slurm_'.$label.'.out';
	$task{'order'} = 'sbatch --parsable '.$task{'filename'};
	$task{'job_name'} = 'myjob';
	$task{'mailtype'} = 'FAIL,TIME_LIMIT,STAGE_OUT';
	return %task;
}
 
sub send2slurm{
	my %task = %{$_[0]};
	my %dtask = define_task();
	my $scriptfile;
        if(exists($task{'filename'}) && $task{'filename'}){
                $scriptfile = $task{'filename'};
        }else{
                $scriptfile = $dtask{'filename'};
        }
        open ESS, ">$scriptfile" or die 'Could not create slurm script\n';
	print ESS '#!/bin/bash'."\n";
	print ESS '#SBATCH -J ';
	if(exists($task{'job_name'}) && $task{'job_name'}){
		print ESS $task{'job_name'}."\n";
	}else{
		print ESS $dtask{'job_name'}."\n";
	}
	if(exists($task{'cpus'}) && $task{'cpus'}){
		print ESS '#SBATCH -c '.$task{'cpus'}."\n";
		print ESS '#SBATCH --mem-per-cpu=';
		if(exists($task{'mem_per_cpu'}) && $task{'mem_per_cpu'}){
			print ESS $task{'mem_per_cpu'}."\n";
		}else{
			print ESS $dtask{'mem_per_cpu'}."\n";
		}
	}
	if(exists($task{'time'}) && $task{'time'}){
		print ESS '#SBATCH --time='.$task{'time'}."\n";
	}
	if(exists($task{'output'}) && $task{'output'}){
                print ESS '#SBATCH -o '.$task{'output'}.'-%j'."\n";
        }else{
		print ESS '#SBATCH -o '.$dtask{'output'}.'-%j'."\n";
	}
	print ESS '#SBATCH --mail-user='."$ENV{'USER'}\n";
	if(exists($task{'partition'}) && $task{'partition'}){
		print ESS '#SBATCH -p '.$task{'partition'}."\n";
	}
	if(exists($task{'command'}) && $task{'command'}){
		if(exists($task{'mailtype'}) && $task{'mailtype'}){
			print ESS '#SBATCH --mail-type='.$task{'mailtype'}."\n";
		}else{
			print ESS '#SBATCH --mail-type='.$dtask{'mailtype'}."\n";
		}
		print ESS $task{'command'}."\n";
	}else{
		print ESS '#SBATCH --mail-type=END'."\n";
		print ESS ":\n";
	}
	close ESS;
	my $order;
	if(exists($task{'dependency'}) && $task{'dependency'}){
		$order = 'sbatch --parsable --dependency='.$task{'dependency'}.' '.$scriptfile;
	}else{
		$order = 'sbatch --parsable '.$scriptfile;
	}
	my $code = qx/$order/;
	chomp $code;
	return $code;
}
neuroimagen/neuro4.pm.txt · Last modified: 2021/02/19 09:48 by osotolongo