Detritus Wiki

User Tools

Site Tools

Trace: • neuro4.pm
neuroimagen:neuro4.pm

This is an old revision of the document!

Table of Contents

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

  • 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.1613728035.txt.gz · Last modified: 2021/02/19 09:47 by osotolongo

Page Tools

Except where otherwise noted, content on this wiki is licensed under the following license: CC Attribution-Share Alike 4.0 International
CC Attribution-Share Alike 4.0 International Donate Powered by PHP Valid HTML5 Valid CSS Driven by DokuWiki