├── hooks └── pre-commit ├── inst ├── extdata │ ├── testfile000.dat │ ├── testfile001.dat │ ├── testfile002.dat │ ├── C2_bin.dat │ ├── C2_pi0.dat │ └── outprcvn.dddd.00.0000 ├── figures │ └── hadron.png ├── new_matrixfit.Rmd └── weighted_model.Rmd ├── .vimrc ├── tests ├── testthat │ ├── test_dummy.R │ ├── test_removeTemporal.R │ ├── test_computeDisc.R │ ├── test_string2error.R │ ├── test_parlist.R │ ├── test_extractSingleCor_cf.R │ ├── test_bootstrapfit.R │ └── test_tex_catwitherror.R ├── testthat.R ├── new_matrixfit_all_points.Rmd └── single_constant_model.Rmd ├── data ├── datalist ├── loopdata.RData ├── samplecf.RData ├── plaq.sample.RData ├── pscor.sample.RData ├── correlatormatrix.RData └── cA2.09.48_3pi_I3_0_A1u_1_pc.RData ├── R ├── kappa.R ├── tflops.R ├── correlatedRNG.R ├── nucleonfs.R ├── fitmass.R ├── g1.R ├── getCor.R ├── getfit.boot.R ├── block.R ├── momentum_utils.R ├── inv_cosh.R ├── LuescherMethod.R ├── CExp.R ├── seed.R ├── getNxNmatrix.R ├── functional.R ├── deriv_utils.R ├── string2error.R ├── h5utils.R ├── zeta_zp.R ├── prop_error.R ├── alpha_s.R ├── fit.plateau2cf.R ├── boot_ts_array.R ├── legacy_functions.R ├── invertCovMatrix.R ├── tikzutils.R ├── fs.mpia0.R ├── jackknifeafterboot.R └── bootstrapnumber.R ├── src ├── alpha_s.h ├── Makevars.win ├── Makevars.in ├── inv_cosh.c ├── cdh.h └── tmcdh.c ├── test ├── exec ├── scatteringlength │ ├── fscor.R │ ├── plot-deltaE.R │ ├── get_finite_range_fits-ratio.R │ ├── plot-ratios.R │ ├── analysis.R │ ├── test-ratio.R │ ├── get_summary.R │ ├── test-data.R │ ├── get_summary-efm.R │ ├── gather-deltaE-values.R │ ├── get_summary-ratio.R │ └── plot-mpia0.R ├── putonlinetogether.sh ├── puttogether.sh ├── puttogether_reverse.sh ├── phaseshift │ ├── parameters.R │ ├── get-phaseshifts.R │ ├── finish.R │ ├── analyse.R │ ├── pipi.R │ ├── test-rootfinding.R │ ├── singlepi.R │ └── phaseshift.pipiswave.R ├── mesons-cmi │ ├── man │ │ └── plot.cfit.Rd │ ├── summary.a0fit.R │ └── summary.b1fit.R ├── old │ ├── kaon.Rd │ ├── oldplotutils.R │ ├── man │ │ └── avercycle.Rd │ ├── cmfit.R │ ├── fit_fp.R │ ├── analyseOS.R │ ├── avercycle.R │ ├── gsl_fit.R │ ├── nucleon.R │ ├── variational.R │ └── ana.R ├── rho-phaseshift │ ├── infile-analyse.R │ ├── average.data.R │ ├── detect_irrep_frame.R │ ├── infile-fit.delta.R │ ├── plot-delta.R │ ├── plot-Mrho.R │ └── summarise.R ├── hdf5-example.R ├── averx │ ├── perform-weighted-median.R │ └── perform-fits.R ├── online_measurements_analysis_driver_template.R ├── analyse.pion0.2x2.R ├── analyse.pion.2x2.R ├── online_measurements_status_template.Rmd ├── analyse.nd-kaon.8x8.R └── analyse.eta_ss.R ├── CONTRIBUTING.md ├── hadron.Rproj ├── .gitignore ├── check ├── install ├── cleanup ├── document ├── .Rbuildignore ├── notes └── Matrixfit_Performance.Rmd ├── NEWS.md ├── README.md ├── vignettes ├── jackknife_cov_and_missing_values.Rmd ├── Two_Amplitudes_Model.Rmd ├── jackknife_error_normalization.Rmd └── hankel.bib ├── configure.ac ├── verify-exports ├── .clang-format └── DESCRIPTION /hooks/pre-commit: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /inst/extdata/testfile000.dat: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /inst/extdata/testfile001.dat: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /inst/extdata/testfile002.dat: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.vimrc: -------------------------------------------------------------------------------- 1 | set shiftwidth=2 2 | set softtabstop=2 3 | -------------------------------------------------------------------------------- /tests/testthat/test_dummy.R: -------------------------------------------------------------------------------- 1 | ## Dummy test such that this directory exists. 2 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(hadron) 3 | 4 | test_check("hadron") 5 | -------------------------------------------------------------------------------- /data/datalist: -------------------------------------------------------------------------------- 1 | plaq.sample 2 | pscor.sample 3 | samplecf 4 | correlatormatrix 5 | loopdata 6 | -------------------------------------------------------------------------------- /data/loopdata.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/HISKP-LQCD/hadron/HEAD/data/loopdata.RData -------------------------------------------------------------------------------- /data/samplecf.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/HISKP-LQCD/hadron/HEAD/data/samplecf.RData -------------------------------------------------------------------------------- /data/plaq.sample.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/HISKP-LQCD/hadron/HEAD/data/plaq.sample.RData -------------------------------------------------------------------------------- /data/pscor.sample.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/HISKP-LQCD/hadron/HEAD/data/pscor.sample.RData -------------------------------------------------------------------------------- /inst/extdata/C2_bin.dat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/HISKP-LQCD/hadron/HEAD/inst/extdata/C2_bin.dat -------------------------------------------------------------------------------- /inst/extdata/C2_pi0.dat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/HISKP-LQCD/hadron/HEAD/inst/extdata/C2_pi0.dat -------------------------------------------------------------------------------- /inst/figures/hadron.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/HISKP-LQCD/hadron/HEAD/inst/figures/hadron.png -------------------------------------------------------------------------------- /data/correlatormatrix.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/HISKP-LQCD/hadron/HEAD/data/correlatormatrix.RData -------------------------------------------------------------------------------- /data/cA2.09.48_3pi_I3_0_A1u_1_pc.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/HISKP-LQCD/hadron/HEAD/data/cA2.09.48_3pi_I3_0_A1u_1_pc.RData -------------------------------------------------------------------------------- /R/kappa.R: -------------------------------------------------------------------------------- 1 | kappa <- function(m0) { 2 | return(1./(2*m0 + 8)) 3 | } 4 | 5 | m0 <- function(kappa) { 6 | return(1./2/kappa - 4) 7 | } 8 | -------------------------------------------------------------------------------- /src/alpha_s.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | 3 | double alphas_c( 4 | const double mu, const int nl, const double lam0, const int Nc, const int Nf); 5 | -------------------------------------------------------------------------------- /R/tflops.R: -------------------------------------------------------------------------------- 1 | tflops <- function(L, Time, N, tau, nconf=1000) { 2 | res <- L^3*Time*nconf*tau*N*(1356+168)/(1000^4*365*24*60*60) 3 | return(res) 4 | } 5 | -------------------------------------------------------------------------------- /test: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Copyright © 2019 Martin Ueding 3 | 4 | set -e 5 | set -u 6 | 7 | ./document 8 | Rscript -e 'devtools::test();' 9 | -------------------------------------------------------------------------------- /src/Makevars.win: -------------------------------------------------------------------------------- 1 | ## lines below supplied by Brian Ripley and Uwe Ligges 2 | ## for gsl package, which we took over 3 | 4 | PKG_CPPFLAGS=-I$(LIB_GSL)/include 5 | PKG_LIBS=-L$(LIB_GSL)/lib -lgsl -lgslcblas 6 | -------------------------------------------------------------------------------- /exec/scatteringlength/fscor.R: -------------------------------------------------------------------------------- 1 | bla <- read.table("scatteringlenght.dat") 2 | L <- bla$V2 3 | mps <- bla$V4 4 | fps <- bla$V5 5 | rpi <- mps^2/(4.0*pi*fps)^2*g1( L*mps ) 6 | 7 | data.frame((1-0.5*rpi), (1+2*rpi)) 8 | -------------------------------------------------------------------------------- /exec/scatteringlength/plot-deltaE.R: -------------------------------------------------------------------------------- 1 | require(tikzDevice) 2 | 3 | 4 | tikz('deltaEovL.tex', standAlone = TRUE, width=5, height=5) 5 | 6 | 7 | 8 | dev.off() 9 | tools::texi2dvi('deltaEovL.tex',pdf=T) 10 | -------------------------------------------------------------------------------- /exec/putonlinetogether.sh: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | ls onlinemeas* | sort -k 2 -t "." | xargs grep "^[0-6][ 0-9] ." | grep -v "^21" | sed -e 's/:/ /g' | sed -e 's/onlinemeas\.//g' | awk '{print $2 " " $3 " " $4 " " $5 " " $6 " " $1'} > piononline.dat 4 | -------------------------------------------------------------------------------- /exec/puttogether.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # $Id$ 3 | 4 | ls outprc* | sort -k 3 -t "." | xargs grep "^ [ 0-2][ 0-9] ." | grep -v "^ 21" | sed -e 's/://g' | sed -e 's/outpr.*\...\.//g' | awk '{print $2 " " $3 " " $4 " " $5 " " $6 " " $1'} > pion.dat 5 | -------------------------------------------------------------------------------- /exec/puttogether_reverse.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # $Id$ 3 | 4 | ls outprc* | sort -r -k 3 -t "." | xargs grep "^ [ 0-2][ 0-9] ." | grep -v "^ 21" | sed -e 's/://g' | sed -e 's/outpr.*\...\.//g' | awk '{print $2 " " $3 " " $4 " " $5 " " $6 " " $1'} > pion.dat 5 | -------------------------------------------------------------------------------- /src/Makevars.in: -------------------------------------------------------------------------------- 1 | ## Kindly supplied by Dirk Eddelbuettel for 2 | ## the gsl package, which we took over 3 | # set by configure 4 | GSL_CFLAGS = @GSL_CFLAGS@ 5 | GSL_LIBS = @GSL_LIBS@ 6 | 7 | # combine to standard arguments for R 8 | PKG_CPPFLAGS = $(GSL_CFLAGS) -I. 9 | PKG_LIBS = $(GSL_LIBS) 10 | -------------------------------------------------------------------------------- /exec/phaseshift/parameters.R: -------------------------------------------------------------------------------- 1 | seed <- 5367887 2 | boot.R <- 1500 3 | boot.l <- 1 4 | 5 | T <- 64 6 | L <- 32 7 | dvec <- c(0,0,0) 8 | 9 | l <- 0 10 | m <- 0 11 | 12 | debug <- FALSE 13 | redofit <- FALSE 14 | 15 | interpolate <- TRUE 16 | interpolation.n <- 100 17 | 18 | srcpath <- "./" 19 | path <- "./" 20 | 21 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing 2 | 3 | ## Pull requests 4 | 5 | In general changes are proposed via pull requests on GitHub. Such requests 6 | should be reviewed by one of the other contributors and pass tests on Travis 7 | CI. 8 | 9 | ## Styleguide 10 | 11 | Comments should be prefixed with `## ` whereas commented out code is prefixed 12 | with `# `. 13 | 14 | -------------------------------------------------------------------------------- /hadron.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | BuildType: Package 16 | PackageUseDevtools: Yes 17 | PackageInstallArgs: --no-multiarch --with-keep.source 18 | -------------------------------------------------------------------------------- /R/correlatedRNG.R: -------------------------------------------------------------------------------- 1 | corrnorm <- function(C, n) { 2 | U <- chol(C) 3 | nC <- dim(C)[1] 4 | N <- (n %% nC) + n 5 | result <- array(rnorm(N), dim=c(N/nC,nC)) %*% U 6 | return(invisible(result[1:n])) 7 | } 8 | 9 | corrnorm2 <- function(C, n) { 10 | U <- chol(C) 11 | nC <- dim(C)[1] 12 | N <- (n %% nC) + n 13 | result <- array(rnorm(N), dim=c(N/nC,nC)) %*% U 14 | return(invisible(result)) 15 | } 16 | -------------------------------------------------------------------------------- /R/nucleonfs.R: -------------------------------------------------------------------------------- 1 | # this is only the asymptotic formula for the FS corrections 2 | # of the nucleon mass as found in 3 | # hep-lat/0403015 4 | nucleonfs <- function(amN, gA, gDelta = 1.4, Delta, L, ampi, aF0) { 5 | # eq(17) 6 | deltaNA <- (9.*gA^2*ampi/(8*pi*aF0^2) + 4.*gDelta^2*ampi^{5/2}/((2*pi)^(3/2)*aF0^2*Delta*sqrt(L))) * 7 | exp(-ampi*L)/L 8 | return(invisible(list(amNV = amN - deltaNA))) 9 | } 10 | 11 | -------------------------------------------------------------------------------- /R/fitmass.R: -------------------------------------------------------------------------------- 1 | fitmass <- function(Cor, Err, t1, t2, Time, par=c(1.,0.12), sign, 2 | fit.routine="optim") { 3 | Thalf <- Time/2 4 | T1 <- Thalf+1 5 | t1p1 <- (t1+1) 6 | t2p1 <- (t2+1) 7 | tr <- (t2-t1+1) 8 | 9 | fit <- optim(par, ChiSqr.singleCor, method="BFGS", Thalf=Thalf, 10 | x=c((t1):(t2)), y=Cor, err=Err, tr=tr, sign=sign) 11 | 12 | return(abs(fit$par[2])) 13 | } 14 | -------------------------------------------------------------------------------- /exec/scatteringlength/get_finite_range_fits-ratio.R: -------------------------------------------------------------------------------- 1 | source("fit_finite_range.R") 2 | 3 | res.finite.range.fit <- fit.finite.range(typ="-ratio") 4 | 5 | save(res.finite.range.fit, file="res-finite-range-fit-ratio.Rdata") 6 | 7 | rm(res.finite.range.fit) 8 | 9 | 10 | res.finite.range.fit.qcotdelta <- fit.finite.range.qcotdelta(typ="-ratio") 11 | 12 | save(res.finite.range.fit.qcotdelta, file="res-finite-range-fit-qcotdelta-ratio.Rdata") 13 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.so 3 | *~ 4 | ..Rcheck/ 5 | .configure 6 | .RData 7 | .Rhistory 8 | .Rproj.user 9 | autom4te.cache 10 | config.log 11 | config.status 12 | docs/ 13 | functions_with_boot_R.txt 14 | hadron.Rcheck 15 | hadron_*.tar.gz 16 | man/*.Rd 17 | man/.Rhistory 18 | NAMESPACE 19 | R/RcppExports.R 20 | src/RcppExports.cpp 21 | src/symbols.rds 22 | tags 23 | vignettes/*.html 24 | vignettes/*.log 25 | vignettes/*.pdf 26 | configure 27 | /doc/ 28 | /Meta/ 29 | src/Makevars 30 | -------------------------------------------------------------------------------- /R/g1.R: -------------------------------------------------------------------------------- 1 | #' g1 2 | #' 3 | #' @description 4 | #' Implementation of the Gasser-Leutwyler function g_1 for 5 | #' computing finite volume effects. 6 | #' 7 | #' @param x Numeric. x-value 8 | #' 9 | #' @export 10 | g1 <- function(x) { 11 | 12 | weights <- c(6.,12.,8.,6.,24.,24.,0.,12.,30.,24.,24.,8.,24.,48.,0.,6.,48.,36.,24.,24.) 13 | ex <- c(1:20) 14 | res <- x 15 | for( i in 1:length(x)) { 16 | sex <- x[i]*sqrt(ex) 17 | res[i] <- sum(4*weights*besselK(sex, 1)/(sex)) 18 | } 19 | return(res) 20 | } 21 | -------------------------------------------------------------------------------- /exec/mesons-cmi/man/plot.cfit.Rd: -------------------------------------------------------------------------------- 1 | \name{plot.cfit} 2 | \alias{plot.cfit} 3 | \title{Plot Command For Class Cfit} 4 | \description{ 5 | Plot Command For Class Cfit 6 | } 7 | \usage{ 8 | plot.cfit <- function(fit) 9 | } 10 | \arguments{ 11 | \item{fit}{ 12 | object of class \code{cfit} 13 | } 14 | } 15 | \value{ 16 | a plot 17 | } 18 | \seealso{ 19 | \code{\link{rho}}, \code{\link{pion}} 20 | } 21 | \author{Carsten Urbach, \email{carsten.urbach@liverpool.ac.uk}} 22 | \keyword{methods} 23 | \keyword{hplot} 24 | 25 | -------------------------------------------------------------------------------- /check: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Copyright © 2019 Martin Ueding 3 | 4 | set -e 5 | set -u 6 | 7 | version=$(grep Version: DESCRIPTION | cut -d ' ' -f 2) 8 | 9 | ./document 10 | R CMD build . 11 | R CMD check --as-cran hadron_$version.tar.gz 12 | 13 | # Unfortunately the `R CMD check` does not reflect warnings in the exit code. 14 | # Also the Travic CI setting `warnings_are_errors` does not have the desired 15 | # effect. We therefore need to check the output for the word `WARNING`. 16 | ! grep WARNING hadron.Rcheck/00check.log 17 | -------------------------------------------------------------------------------- /tests/testthat/test_removeTemporal.R: -------------------------------------------------------------------------------- 1 | context('Remove Temporal') 2 | 3 | test_that('equality', { 4 | ## Perform some fits to the sample cf such that we have energies to subtract. 5 | corr_boot <- bootstrap.cf(samplecf) 6 | 7 | fit1 <- matrixfit(corr_boot, 10, 20) 8 | fit2 <- matrixfit(corr_boot, 4, 9) 9 | 10 | corr_rt <- old_removeTemporal.cf(corr_boot, fit1, fit2, L = 24, weight.cosh = FALSE) 11 | new_corr_rt <- removeTemporal.cf(corr_boot, fit1, fit2, L = 24, weight.cosh = FALSE) 12 | expect_equal(corr_rt, new_corr_rt) 13 | }) 14 | -------------------------------------------------------------------------------- /install: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | set -u 5 | 6 | while getopts "qch" opt; do 7 | case $opt in 8 | q) 9 | Rscript --vanilla -e "devtools::install(quick=TRUE)" 10 | exit 11 | ;; 12 | c) 13 | Rscript --vanilla -e "devtools::check(cran=TRUE)" 14 | exit 15 | ;; 16 | h) 17 | echo -e " 18 | Install hadron package\n 19 | Usage: $0 [-q] [-h]\n 20 | -q: quick install 21 | -c: check CRAN 22 | -h: help\n" 23 | exit 24 | ;; 25 | esac 26 | done 27 | 28 | ./document 29 | Rscript --vanilla -e "devtools::install()" 30 | -------------------------------------------------------------------------------- /tests/testthat/test_computeDisc.R: -------------------------------------------------------------------------------- 1 | context('computeDisc') 2 | 3 | test_that('cross_vs_diagonal', { 4 | data(loopdata) 5 | X1 <- computeDisc(cf=loopdata, real=TRUE, subtract.vev=TRUE) 6 | X2 <- computeDisc(cf=loopdata, cf2=loopdata, real=TRUE, real2=TRUE, subtract.vev=TRUE, subtract.vev2=TRUE) 7 | expect_equal(sum(X1$cf-X2$cf), 0) 8 | 9 | X1 <- computeDisc(cf=loopdata, real=TRUE, subtract.vev=FALSE) 10 | X2 <- computeDisc(cf=loopdata, cf2=loopdata, real=TRUE, real2=TRUE, subtract.vev=FALSE, subtract.vev2=FALSE) 11 | expect_equal(sum(X1$cf-X2$cf), 0) 12 | } 13 | ) 14 | -------------------------------------------------------------------------------- /cleanup: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | for f in ./config.*; do 3 | rm -f $f 4 | done 5 | if [ -e src/Makevars ]; then 6 | rm -f src/Makevars 7 | fi 8 | exit 0 9 | -------------------------------------------------------------------------------- /inst/extdata/outprcvn.dddd.00.0000: -------------------------------------------------------------------------------- 1 | 1 1 0 3.373138e-03 -1.562338e-14 2 | 1 1 1 -1.346180e-07 -7.806412e-15 3 | 1 1 2 -1.591981e-09 -3.064034e-15 4 | 2 1 0 1.201763e-07 3.306667e-13 5 | 2 1 1 2.247590e-08 4.268303e-14 6 | 2 1 2 2.205283e-10 -4.652930e-15 7 | 3 1 0 -4.634664e-07 5.981648e-13 8 | 3 1 1 4.554605e-09 4.160628e-14 9 | 3 1 2 -1.516907e-11 -2.051918e-15 10 | 4 1 0 3.387673e-03 3.249161e-14 11 | 4 1 1 1.308723e-06 1.430134e-14 12 | 4 1 2 2.479499e-09 1.834287e-15 13 | -------------------------------------------------------------------------------- /document: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | set -u 5 | 6 | autoreconf -vif 7 | 8 | # XXX: Starting with Roxygen version 7.1.0 or some version or Rcpp there is a 9 | # circular dependency on the `NAMESPACE` file. Roxygen will call 10 | # `Rcpp::compileAttributes()` which needs the `NAMESPACE`, which does not exist 11 | # at this point. The hack is to just generate this file without any content but 12 | # with the marker such that Roxygen will overwrite it with the actual output. 13 | if ! [[ -f NAMESPACE ]]; then 14 | echo '# Generated by roxygen2: do not edit by hand' > NAMESPACE 15 | fi 16 | 17 | Rscript --vanilla -e "devtools::document()" 18 | -------------------------------------------------------------------------------- /src/inv_cosh.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include 5 | 6 | SEXP invcosh(SEXP ratio, SEXP timeextent, SEXP t, SEXP eps, SEXP maxiter) { 7 | const double rat = asReal(ratio), epsilon = asReal(eps); 8 | const int dt0 = asInteger(timeextent) - 2 * asInteger(t), dt1 = dt0 + 2; 9 | const int n = asInteger(maxiter); 10 | double newmass = log(rat), mass = 0, r; 11 | int i; 12 | 13 | for (i = 0; i < n && fabs(mass - newmass) >= epsilon * mass; i++) { 14 | mass = newmass; 15 | r = (1 + exp(-mass * dt0)) / (1 + exp(-mass * dt1)); 16 | newmass = log(rat * r); 17 | } 18 | 19 | return ScalarReal(newmass); 20 | } 21 | -------------------------------------------------------------------------------- /R/getCor.R: -------------------------------------------------------------------------------- 1 | getCor <- function(T1, W, Z, type=c("cosh")) { 2 | 3 | ## iobs enumerating the gamma matrix combination 4 | ## ityp enumeratiog the smearing level 5 | N <- length(type) 6 | sign = rep(+1., times=N) 7 | for(i in 1:N) { 8 | if(type[i]=="sinh") { 9 | sign[i] = -1. 10 | } 11 | } 12 | 13 | for(j in 1:N) { 14 | for(i in 1:(T1)) { 15 | two <- 2. 16 | if(i==1 || i==(T1)) { 17 | ## Take care of zeros in the correlators when summing t and T-t+1 18 | two <- 1. 19 | } 20 | 21 | W[(i+(j-1)*T1),] <- (W[(i+(j-1)*T1),] 22 | + sign[j]*Z[(i+(j-1)*T1),])/two 23 | } 24 | } 25 | return(invisible(W)) 26 | } 27 | -------------------------------------------------------------------------------- /exec/old/kaon.Rd: -------------------------------------------------------------------------------- 1 | \name{kaon} 2 | \alias{kaon} 3 | \title{performs the heavy light analysis for tmQCD in the pseudo scalar 4 | and scalar sector} 5 | \description{ 6 | performs the heavy light analysis for tmQCD in the pseudo scalar 7 | and scalar sector. Hence the Kaon and D-meson masses will be 8 | determined 9 | } 10 | \usage{ 11 | kaon() 12 | } 13 | \arguments{ 14 | } 15 | \value{ 16 | } 17 | \details{ 18 | the contraction code computes 19 | g5-g5, g5-1, 1-g5, 1-1, 20 | // g5-g0g5, g0g5-g5, g0g5-g0g5, g0-g0, g5-g0, g0-g5, g0g5-g0, g0-g0g5 21 | // g0g5-1, 1-g0g5, g0-1, 1-g0 22 | } 23 | \references{ 24 | } 25 | \seealso{ 26 | } 27 | \examples{ 28 | } 29 | \author{} 30 | \keyword{} -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | \.swp$ 2 | ^.*\.Rproj$ 3 | ^\.\.Rcheck$ 4 | ^\.clang-format$ 5 | ^\.git$ 6 | ^\.git/ 7 | ^\.gitignore$ 8 | ^\.RData$ 9 | ^\.Rhistory$ 10 | ^\.Rproj\.user$ 11 | ^\.travis\.yml$ 12 | ^\.travis_install_texlive\.R$ 13 | ^\.vimrc$ 14 | vignettes/*RData 15 | vignettes/*log 16 | vignettes/*pdf 17 | vignettes/*html 18 | CONTRIBUTING.md 19 | Weighted_Model.nb 20 | install 21 | document 22 | check 23 | test 24 | test_readbinarysamples.Rmd 25 | notes/ 26 | test 27 | hooks/ 28 | inst/*.Rmd 29 | test_bootstrap_nlsfit.Rmd 30 | verify-exports 31 | exec/scatteringlength 32 | exec/old 33 | exec/phaseshift 34 | exec/rho-phaseshift 35 | exec/averx 36 | exec/put* 37 | R/jackknifeafterboot.R 38 | #R/boot_ts_array.R 39 | ^doc$ 40 | ^Meta$ 41 | -------------------------------------------------------------------------------- /R/getfit.boot.R: -------------------------------------------------------------------------------- 1 | getfit.boot <- function(Z, d, Err, t1, t2, Time, par=c(1.,0.12), 2 | fit.routine="optim", sign) { 3 | Thalf <- Time/2 4 | T1 <- Thalf+1 5 | t1p1 <- (t1+1) 6 | t2p1 <- (t2+1) 7 | tr <- (t2-t1+1) 8 | Cor <- rep(0., times=length(Z[1,])) 9 | if(!missing(d)) { 10 | for(i in 1:length(Z[1,])) { 11 | Cor[i] = mean(Z[d,(i)]) 12 | } 13 | } 14 | else { 15 | for(i in 1:length(Z[1,])) { 16 | Cor[i] = mean(Z[,(i)]) 17 | } 18 | } 19 | 20 | fit <- optim(par, ChiSqr.singleCor, method="BFGS", Thalf=Thalf, 21 | x=c((t1):(t2)), y=Cor, err=Err, tr=tr, sign=sign) 22 | sort.ind <- c(1) 23 | return(c(abs(fit$par[2]), fit$par[1], 24 | fit$value)) 25 | } 26 | -------------------------------------------------------------------------------- /exec/rho-phaseshift/infile-analyse.R: -------------------------------------------------------------------------------- 1 | ## Input file with default parameters 2 | args <- list( 3 | ens = "A30.32", 4 | path.to.data = c("/home/maow/Build/sLapH-projection/A30.32-for-testing/3_gevp-data/"), 5 | output.path = "/home/maow/Build/sLapH-projection/A30.32-for-testing/", 6 | disp = c("lat"), 7 | maxpcs = 3, 8 | L = 32, 9 | T = 64, 10 | t0 = 2, 11 | t10 = c(7, 5, 5), 12 | t11 = c(11, 11, 11), 13 | t21 = c(19, 17, 15), 14 | t.step = 2, 15 | # disp = "lat", 16 | # type = "subtracted", 17 | reread = FALSE, 18 | dirs = c("p0/T1u"), 19 | # dirs = c("p0/T1u", "p1/A1g", "p1/E", "p2/A1", "p2/B1", "p2/B2", "p3/A1", "p3/E", "p4/A1", "p4/E"), 20 | boot.R = 1500, 21 | boot.l = 4, 22 | seed = 1234 23 | ) 24 | 25 | -------------------------------------------------------------------------------- /exec/phaseshift/get-phaseshifts.R: -------------------------------------------------------------------------------- 1 | source("parameters.R") 2 | 3 | source("../phaseshift.pipiswave.R") 4 | phaseshift.pipi.swave(PC="pc1", tp="TP0", boot.R=boot.R, boot.l=boot.l, L=L, T=T, dvec=c(0,0,0), debug=TRUE, p1=c(0,0,0), p2=c(0,0,0)) 5 | phaseshift.pipi.swave(PC="pc2", tp="TP0", boot.R=boot.R, boot.l=boot.l, L=L, T=T, dvec=c(0,0,0), debug=TRUE, p1=c(0,0,0), p2=c(0,0,0)) 6 | phaseshift.pipi.swave(PC="pc1", tp="TP1", boot.R=boot.R, boot.l=boot.l, L=L, T=T, dvec=c(0,0,1), debug=TRUE, p1=c(0,0,1), p2=c(0,0,0)) 7 | phaseshift.pipi.swave(PC="pc1", tp="TP2", boot.R=boot.R, boot.l=boot.l, L=L, T=T, dvec=c(0,1,1), debug=TRUE, p1=c(0,1,1), p2=c(0,0,0)) 8 | phaseshift.pipi.swave(PC="pc1", tp="TP3", boot.R=boot.R, boot.l=boot.l, L=L, T=T, dvec=c(1,1,1), debug=TRUE, p1=c(1,1,1), p2=c(0,0,0)) 9 | 10 | -------------------------------------------------------------------------------- /exec/hdf5-example.R: -------------------------------------------------------------------------------- 1 | library(rhdf5) 2 | 3 | ## assume you have an hdf5 file "h5file" 4 | 5 | ## find out the hdf5 datasets in this file 6 | 7 | file <- "h5file" 8 | 9 | h5ls(file) 10 | 11 | ## decide which one you need, say 12 | 13 | dsname <- "correlator" 14 | 15 | ## then you may 16 | 17 | x <- readbinarycf(files=file, T=96, hdf5format=TRUE, hdf5name=dsname, 18 | hdf5index=c(1,2)) 19 | 20 | ## the data types used in our contraction code are complex. with 21 | ## hdf5index we access real and imaginary part (1,2), respectively. 22 | ## per default 23 | 24 | x$cf 25 | 26 | ## contains the real part and 27 | 28 | x$icf 29 | 30 | ## the imaginary part 31 | ## You may change this with 32 | 33 | x <- readbinarycf(files=file, T=96, hdf5format=TRUE, hdf5name=dsname, 34 | hdf5index=c(2,1)) 35 | -------------------------------------------------------------------------------- /R/block.R: -------------------------------------------------------------------------------- 1 | ## routine to block a vector or a two dimensional array in blocks of length l 2 | ## discards anything that doesn't fit into exact multiples of the block length 3 | ## this is much faster than the blocking 4 | ## of tsboot 5 | block.ts <- function(data, l=2) { 6 | if(l == 1) { 7 | return(invisible(data)) 8 | } 9 | if(is.vector(data)) { 10 | N <- floor(length(data)/l)*l 11 | return( apply(array(data, dim=c(l, N/l)), 2, mean)) 12 | } 13 | if(length(dim(data))!=2) { 14 | stop("block.ts currently only implemented for vectors of 2-dim arrays\n") 15 | } 16 | N <- floor(length(data[,1])/l)*l 17 | ncf <- array(0, dim=c(N/l,length(data[1,]))) 18 | j <- 1 19 | for ( i in seq(1,N,l)) { 20 | ncf[j,] <- apply(data[i:(i+l-1),], 2, mean) 21 | j <- j+1 22 | } 23 | return(invisible(ncf)) 24 | } 25 | -------------------------------------------------------------------------------- /notes/Matrixfit_Performance.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Matrixfit Performance" 3 | author: "Martin Ueding" 4 | date: "6 August 2019" 5 | output: pdf_document 6 | --- 7 | 8 | ```{r setup, include=FALSE} 9 | knitr::opts_chunk$set(echo = TRUE) 10 | 11 | devtools::load_all() 12 | library(profvis) 13 | ``` 14 | 15 | Preparation 16 | 17 | ```{r} 18 | samplecf_boot <- bootstrap.cf(samplecf, 1500) 19 | args <- list(samplecf_boot, 5, 10, fit.method = 'lm', model = 'single') 20 | ``` 21 | 22 | ```{r} 23 | profile_old <- profvis({ 24 | fit_old <- do.call(old_matrixfit, args) 25 | }) 26 | ``` 27 | 28 | ```{r} 29 | profile_new <- profvis({ 30 | fit_new <- do.call(matrixfit, args) 31 | }) 32 | ``` 33 | 34 | ```{r} 35 | table(fit_old$niter) 36 | ``` 37 | 38 | ```{r} 39 | table(fit_new$niter) 40 | ``` 41 | 42 | 43 | ```{r} 44 | print(profile_old) 45 | print(profile_new) 46 | ``` 47 | 48 | -------------------------------------------------------------------------------- /R/momentum_utils.R: -------------------------------------------------------------------------------- 1 | #' @title Generate table of momentum component combinations 2 | #' @param psqmax Integer, maximum p^2 = px^2 + py^2 + pz^2 to be included in momentum list 3 | #' 4 | #' @return 5 | #' Returns a \link{data.frame} with all possible momentum combinations. 6 | #' 7 | #' @export 8 | mom_combinations <- function(psqmax){ 9 | pmax <- ceiling(sqrt(psqmax))+1 10 | pseq <- (-pmax):pmax 11 | moms <- NULL 12 | for( px in pseq ){ 13 | for( py in pseq ){ 14 | for( pz in pseq ){ 15 | if( px^2 + py^2 + pz^2 <= psqmax ) 16 | moms <- rbind(moms, 17 | data.frame(px=px, py=py, pz=pz)) 18 | } 19 | } 20 | } 21 | srt_idcs <- order(moms$px^2 + moms$py^2 + moms$pz^2, 22 | abs(moms$px), abs(moms$py), abs(moms$pz)) 23 | moms <- moms[srt_idcs,] 24 | rownames(moms) <- NULL 25 | 26 | return( moms ) 27 | } 28 | -------------------------------------------------------------------------------- /tests/testthat/test_string2error.R: -------------------------------------------------------------------------------- 1 | context('string2error') 2 | 3 | test_that('1', { 4 | expect_equal(string2error('3.10(2)'), c(3.10, 0.02)) 5 | expect_equal(string2error('+3.10(2)'), c(3.10, 0.02)) 6 | expect_equal(string2error('-3.10(2)'), c(-3.10, 0.02)) 7 | 8 | expect_equal(string2error('310(2)'), c(310, 2)) 9 | expect_equal(string2error('-310(2)'), c(-310, 2)) 10 | 11 | expect_equal(string2error('0.001(2)'), c(0.001, 0.002)) 12 | expect_equal(string2error('0.001(20)'), c(0.001, 0.020)) 13 | expect_equal(string2error('0.001(200)'), c(0.001, 0.200)) 14 | expect_equal(string2error('0.001(2000)'), c(0.001, 2.000)) 15 | expect_equal(string2error('0.001(20000)'), c(0.001, 20.000)) 16 | 17 | expect_equal(string2error('.001(2)'), c(0.001, 0.002)) 18 | expect_equal(string2error('-.001(2)'), c(-0.001, 0.002)) 19 | expect_equal(string2error('310.(2)'), c(310, 2)) 20 | expect_equal(string2error('-310.(2)'), c(-310, 2)) 21 | }) 22 | -------------------------------------------------------------------------------- /R/inv_cosh.R: -------------------------------------------------------------------------------- 1 | #' @title numerically invert the cosh function for the mass 2 | #' 3 | #' @param ratio Numeric. The value of the ratio. 4 | #' @param timeextent Integer. Time extent of the lattice. 5 | #' @param t Integer. The t-value where the ratio was taken. 6 | #' @param eps Numeric. Precision of the numerical solution 7 | #' @param maxiterations Integer. Maximal number of iterations to be 8 | #' used in the iterative solver. 9 | #' 10 | #' @useDynLib hadron 11 | #' @importFrom Rcpp evalCpp 12 | #' 13 | #' @return 14 | #' A single numeric value is returned corresponding to the mass. 15 | #' @examples 16 | #' 17 | #' invcosh(1.2, timeextent=24, t=12) 18 | #' @export 19 | invcosh <- function(ratio, timeextent, t, eps=1.e-9, maxiterations=1000) { 20 | 21 | if(ratio < 1 || is.na(ratio)) { 22 | return(NA); 23 | # stop("Error: ratio is smaller than 1 in invcosh!") 24 | } 25 | 26 | return(.Call("invcosh", ratio, timeextent, t, eps, maxiterations)) 27 | } 28 | -------------------------------------------------------------------------------- /exec/phaseshift/finish.R: -------------------------------------------------------------------------------- 1 | source("parameters.R") 2 | pdf(file="finish.pdf") 3 | 4 | pc <- "pc1" 5 | TP <- "TP0" 6 | source("../summary.R") 7 | sr <- array(c(qsqovmpisq, qcotdeltaovmpi, delta, qsq, qcotdelta, Epi, Epipi, q), dim=c(1,32)) 8 | 9 | save(sr, file="sr.Rdata") 10 | 11 | pc <- "pc2" 12 | TP <- "TP0" 13 | source("../summary.R") 14 | sr <- rbind(sr, c(qsqovmpisq, qcotdeltaovmpi, delta, qsq, qcotdelta, Epi, Epipi, q)) 15 | 16 | pc <- "pc1" 17 | TP <- "TP1" 18 | source("../summary.R") 19 | sr <- rbind(sr, c(qsqovmpisq, qcotdeltaovmpi, delta, qsq, qcotdelta, Epi, Epipi, q)) 20 | 21 | pc <- "pc1" 22 | TP <- "TP2" 23 | source("../summary.R") 24 | sr <- rbind(sr, c(qsqovmpisq, qcotdeltaovmpi, delta, qsq, qcotdelta, Epi, Epipi, q)) 25 | 26 | pc <- "pc1" 27 | TP <- "TP3" 28 | source("../summary.R") 29 | sr <- rbind(sr, c(qsqovmpisq, qcotdeltaovmpi, delta, qsq, qcotdelta, Epi, Epipi, q)) 30 | 31 | sr 32 | 33 | save(sr, file="sr.Rdata") 34 | dev.off() 35 | 36 | -------------------------------------------------------------------------------- /exec/phaseshift/analyse.R: -------------------------------------------------------------------------------- 1 | source("parameters.R") 2 | 3 | source("singlepi.R") 4 | 5 | singlepi(t1=14, t2=T/2, T=T, p="p0", srcpath=srcpath) 6 | singlepi(t1=14, t2=T/2, T=T, p="p1", srcpath=srcpath) 7 | singlepi(t1=11, t2=22, T=T, p="p2", srcpath=srcpath) 8 | singlepi(t1=10, t2=15, T=T, p="p3", srcpath=srcpath) 9 | singlepi(t1=10, t2=15, T=T, p="p4", srcpath=srcpath) 10 | 11 | source("pipi.R") 12 | 13 | energies.pipi(boot.R=boot.R, boot.l=boot.l, redofit=redofit, tp="TP0", N=5, seed=seed, T=T, N.ids=2, t1=c(9,8,5), t2=c(26, 15, 13), srcpath=srcpath) 14 | energies.pipi(boot.R=boot.R, boot.l=boot.l, redofit=redofit, tp="TP1", N=4, seed=seed, T=T, N.ids=1, t1=c(9,8,5), t2=c(24, 15, 13), srcpath=srcpath) 15 | energies.pipi(boot.R=boot.R, boot.l=boot.l, redofit=redofit, tp="TP2", N=5, seed=seed, T=T, N.ids=1, t1=c(8,6,5), t2=c(17, 15, 13), srcpath=srcpath) 16 | energies.pipi(boot.R=boot.R, boot.l=boot.l, redofit=redofit, tp="TP3", N=3, seed=seed, T=T, N.ids=1, t1=c(5,6,6), t2=c(16, 15, 13), srcpath=srcpath) 17 | 18 | -------------------------------------------------------------------------------- /R/LuescherMethod.R: -------------------------------------------------------------------------------- 1 | ## This file contains routines needed in the context of the Luescher method 2 | ## for investigating unstable particles in a finite box with 3 | ## Euclidean metric 4 | 5 | ## compute the lattice scattering momentum \tilde q 6 | 7 | ## default version with lattice dispersion relation 8 | compute.qtildesq <- function(E, dvec, mpi, L) { 9 | ## center of mass energy 10 | ## cosh(Ecm) = cosh(E) - 2 sum sin^2(Pi/2) 11 | Ecm <- acosh(cosh(E) - 2*sum(sin(pi*dvec/L)^2)) 12 | ## scattering momentum 13 | ## cosh(Ecm/2) = 2 sin^2(q*/2) + cosh(mpi) 14 | q = 2*asin(sqrt( (cosh(Ecm/2) - cosh(mpi))/2. )) 15 | ## qtsq = 2 pi q / L 16 | return(data.frame(gammaboost=E/Ecm, qtsq=(L*q/2./pi)^2, q=q, Ecm=Ecm)) 17 | } 18 | 19 | ## version with continuum dispersion relation 20 | compute.qtildesq.contdisp <- function(E, dvec, mpi, L) { 21 | Ecmsq <- E^2 - sum((2*pi*dvec/L)^2) 22 | qsq <- Ecmsq/4.-mpi^2 23 | return(data.frame(gammaboost=E/sqrt(Ecmsq), qtsq=qsq*(L/2./pi)^2, q=sqrt(qsq), Ecm=sqrt(Ecmsq))) 24 | } 25 | 26 | -------------------------------------------------------------------------------- /R/CExp.R: -------------------------------------------------------------------------------- 1 | #' Cosh Or Sinh Build Out Of Two Exps 2 | #' 3 | #' Evaluates \deqn{f(x) = \frac{1}{2}(\exp(-m(T-x))\pm\exp(-m x))}{% f(x) = 1/2 4 | #' (exp(-m(T-x)) +/- exp(-m x))} for given mass \eqn{m}, vector \eqn{x} and 5 | #' time extent \eqn{T}. This form is better usable in \eqn{\chi^2}{chi^2} 6 | #' fitting than cosh or sinh. 7 | #' 8 | #' 9 | #' @param m mass value 10 | #' @param Time Time extent 11 | #' @param x vector of values on which to evaluate the function 12 | #' @param sign with sign=1 cosh is evaluated, with sign=-1 sinh 13 | #' @return vector \eqn{f(x)} 14 | #' @author Carsten Urbach \email{carsten.urbach@@liverpool.ac.uk} 15 | #' @keywords math 16 | #' @examples 17 | #' 18 | #' m <- 0.1 19 | #' Time <- 48 20 | #' x <- seq(0, 48, 1) 21 | #' CExp(m=m, Time=Time, x=x) 22 | #' @export CExp 23 | CExp <- function(m, Time, x, sign=1.) { 24 | return(0.5*(exp(-m*(Time-x)) + sign*exp(-m*x))) 25 | } 26 | 27 | dCExpdm <- function(m, Time, x, sign=1.) { 28 | return(0.5*(-(Time-x)*exp(-m*(Time-x)) -x* sign*exp(-m*x))) 29 | } 30 | 31 | -------------------------------------------------------------------------------- /exec/rho-phaseshift/average.data.R: -------------------------------------------------------------------------------- 1 | sink("average.data.log", append=FALSE, split=TRUE) 2 | 3 | ## extracts irrep and frame from directory name 4 | ## also defines N for the matrix size 5 | ## and path 6 | source(paste(path.to.hadron, "/detect_irrep_frame.R", sep="/")) 7 | 8 | pdf(file=paste("histograms", ens, frame, irrep, "pdf", sep=".")) 9 | res <- list() 10 | res.all <- list() 11 | res.boot <- list() 12 | for(i in c(1:min(maxpcs, N))) { 13 | if(i == 1) PC <- "pc1" 14 | if(i == 2) PC <- "pc2" 15 | if(i == 3) PC <- "pc3" 16 | if(i == 4) PC <- "pc4" 17 | if(i == 5) PC <- "pc5" 18 | cat("hint", i, hint[i], "\n") 19 | res[[i]] <- summarise.rho(ens=ens, frame=frame, irrep=irrep, PC=PC, hint=hint[i]) 20 | res.all[[i]] <- compute.error.rho(res[[i]], PC=PC) 21 | res.boot[[i]] <- array(0, dim=c(boot.R+1, 3)) 22 | for(j in c(1:3)) { 23 | res.boot[[i]][,j] <- compute.boots(res[[i]], index=j) 24 | } 25 | cat("Ecm:", i, res.all[[i]]$Ecm, "\n") 26 | cat("delta:", i, res.all[[i]]$delta, "\n") 27 | } 28 | dev.off() 29 | rm(i,j) 30 | 31 | save.image(file=paste("res", ens, frame, irrep, "Rdata", sep=".")) 32 | 33 | sink() 34 | -------------------------------------------------------------------------------- /exec/old/oldplotutils.R: -------------------------------------------------------------------------------- 1 | #' plot.pionfit 2 | #' 3 | #' @description 4 | #' Generic function to plot an object of type `pionfit` 5 | #' 6 | #' @param x Object of type `pionfit` 7 | #' @param ... Generic graphical parameter, ignored. 8 | #' 9 | #' @return 10 | #' See \link{plot.cfit} 11 | #' 12 | #' @export 13 | plot.pionfit <- function(x, ...) { 14 | plot.cfit(x) 15 | } 16 | 17 | #' plot.rhofit 18 | #' 19 | #' @description 20 | #' Generic function to plot an object of type `rhofit` 21 | #' 22 | #' @param x Object of type `rhofit` 23 | #' @param ... Generic graphical parameter to be passed on to \link{plotwitherror} 24 | #' 25 | #' @return 26 | #' See \link{plot.cfit} 27 | #' 28 | #' @export 29 | plot.rhofit <- function(x, ...) { 30 | plot.cfit(x) 31 | } 32 | 33 | #' plot.b1fit 34 | #' 35 | #' @description 36 | #' Generic function to plot an object of type `b1fit` 37 | #' 38 | #' @param x Object of type `b1fit` 39 | #' @param ... Generic graphical parameter to be passed on to \link{plotwitherror} 40 | #' 41 | #' @return 42 | #' See \link{plot.cfit} 43 | #' 44 | #' @export 45 | plot.b1fit <- function(x, ...) { 46 | plot.cfit(x) 47 | } 48 | 49 | -------------------------------------------------------------------------------- /tests/new_matrixfit_all_points.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "R Notebook" 3 | output: pdf_document 4 | --- 5 | 6 | ```{r setup} 7 | devtools::load_all() 8 | ``` 9 | 10 | 11 | ```{r} 12 | corr <- bootstrap.cf(samplecf) 13 | ``` 14 | 15 | We want the same plot output with both plot mechanism. 16 | 17 | # `matrixfit` 18 | 19 | ```{r} 20 | old_fit <- matrixfit(corr, 10, 20) 21 | plot(old_fit, do.qqplot = FALSE) 22 | plot(old_fit, 23 | plot.raw = FALSE, 24 | do.qqplot = FALSE, 25 | ylim = c(0.99, 1.01), 26 | main = 'Old Residual Plot') 27 | ``` 28 | 29 | # `new_matrixfit` 30 | 31 | ```{r} 32 | new_fit <- new_matrixfit(corr, 10, 20) 33 | plot(new_fit, log = 'y', supports = 431) 34 | residual_plot(new_fit, 35 | ylim = c(0.99, 1.01), 36 | main = 'New Residual Plot (division)') 37 | residual_plot(new_fit, 38 | ylim = c(-1, 1), 39 | main = 'New Residual Plot (subtraction)', 40 | operation = `-`) 41 | ``` 42 | 43 | ```{r} 44 | npar <- length(new_fit$par.guess) 45 | prediction_val <- do.call(new_fit$fn, c(list(par = new_fit$t0[1:npar], x = new_fit$x, boot.r = 0), new_fit$tofn)) 46 | ``` 47 | 48 | -------------------------------------------------------------------------------- /R/seed.R: -------------------------------------------------------------------------------- 1 | #' Set seed and store a seed which can be used to 2 | #' reset the random number generator 3 | #' 4 | #' @param new_seed integer. The new seed that is to be set. In case this is 5 | #' parameter is missing, no changes are made and the function just returns 6 | #' `NULL`. This is useful because a function can just pass on its own `seed` 7 | #' argument and therefore control whether the seed shall be fixed or left 8 | #' as-is. 9 | #' 10 | #' @return 11 | #' The generated seed is returned if it exists. Otherwise `NULL`. In case that 12 | #' `new_seed` was missing, `NULL` is returned. 13 | swap_seed <- function (new_seed) { 14 | seed_range <- 2^31-1 15 | if (missing(new_seed)) { 16 | return (NULL) 17 | } 18 | 19 | temp <- sample.int(size=1, n=seed_range) 20 | set.seed(new_seed) 21 | 22 | return (temp) 23 | } 24 | 25 | #' Restore random number generator state 26 | #' 27 | #' @return 28 | #' No return value, but the random seed is reset to 29 | #' `old_seed`. 30 | #' 31 | #' @param old_seed integer. Previous seed that should be restored globally. 32 | restore_seed <- function (old_seed) { 33 | if (!is.null(old_seed)) 34 | set.seed(old_seed) 35 | } 36 | -------------------------------------------------------------------------------- /exec/old/man/avercycle.Rd: -------------------------------------------------------------------------------- 1 | \name{avercycle} 2 | \alias{avercycle} 3 | \title{take the cycle average of correlator data in cmicor format} 4 | \description{ 5 | take the cycle average of correlator data in cmicor format 6 | } 7 | \usage{ 8 | avercycle(cmicor, cycle.l) 9 | } 10 | \arguments{ 11 | \item{cmicor}{ 12 | correlator data as obtained with \code{\link{readcmicor}}. 13 | } 14 | \item{cycle.l}{ 15 | the cycle length in units of gauge numbering 16 | } 17 | } 18 | \value{ 19 | returns the averaged correlator data in the same format as provided by 20 | \code{\link{readcmicor}}. 21 | } 22 | \details{ 23 | the function will determine the average number of measurements per 24 | cycle, average the data in each cycle and take care of the appropriate 25 | weight. 26 | 27 | Currently the implementation is very slow. why? 28 | 29 | Averaging the cycles restores translational invariance of the data and 30 | takes properly care of the correlations in between in within the cycles. 31 | } 32 | \seealso{ 33 | \code{\link{readcmicor}} 34 | } 35 | \examples{ 36 | \dontrun{avercycle(cmicor, 10)} 37 | } 38 | \author{Carsten Urbach, \email{curbach@gmx.de}} 39 | \keyword{ts} 40 | -------------------------------------------------------------------------------- /exec/rho-phaseshift/detect_irrep_frame.R: -------------------------------------------------------------------------------- 1 | ## detects the irrep and frame from the directory structure 2 | ## its supposed to be called from a directory with name 3 | ## .../p/ 4 | ## with being the squared momentum in units of 2pi/L 5 | ## and the corresponding irreducible representation 6 | 7 | ## PATH must be set by the calling script to a directory such that 8 | ## the data can be found in PATH/p// 9 | 10 | wd <- getwd() 11 | splitwd <- strsplit(wd, "/")[[1]] 12 | momentum <- splitwd[length(splitwd)-1] 13 | irrep <- splitwd[length(splitwd)] 14 | rm(wd, splitwd) 15 | 16 | momenta <- c("p0", "p1", "p2", "p3", "p4") 17 | 18 | frames <- c("cmf", "mf1", "mf2", "mf3", "mf1") 19 | frameid <- which(momenta == momentum) 20 | frame <- frames[frameid] 21 | 22 | irreps <- list(c("T1u"), c("A1", "E"), c("A1", "B1", "B2"), c("A1", "E"), c("A1", "E")) 23 | irrepid <- which(irreps[[frameid]] == irrep) 24 | sizes <- list(c(3), c(5, 3), c(4, 3, 4), c(4, 3), c(2, 2)) 25 | 26 | path <- paste(args$path.to.data, "/", momentum, "/", irrep, "/", sep="") 27 | 28 | N <- 1 29 | for(N in c(0:10)) { 30 | if(!file.exists(paste(path, "/", "rho", ".", N, ".", N, ".dat", sep=""))) { 31 | break 32 | } 33 | } 34 | -------------------------------------------------------------------------------- /exec/averx/perform-weighted-median.R: -------------------------------------------------------------------------------- 1 | ## needs also ratio.R and analyse_pipi.R 2 | source("summary.R") 3 | 4 | boot.R <- 1500 5 | boot.l <- 1 6 | 7 | ens <- c("cA2.09.48") 8 | 9 | if(file.exists("parameters.R")) { 10 | source("parameters.R") 11 | } 12 | 13 | 14 | if(!file.exists(paste("summary-res.averx.", ens, ".Rdata", sep=""))) { 15 | res <- compile.averxdata(ens=ens) 16 | 17 | save(res, file=paste("summary-res.averx.", ens, ".Rdata", sep="")) 18 | } 19 | load(paste("summary-res.averx.", ens, ".Rdata", sep="")) 20 | 21 | if(!interactive()) pdf(file=paste("whist.", ens, ".pdf", sep="")) 22 | 23 | x1 <- estimate.error(res, index=1, main=c("_1 weighted histogram"), Qval=res[1,,c(4,5)]) 24 | x1boot <- compute.boots(res, index=1, Qval=res[1,,c(4,5)]) 25 | 26 | x2 <- estimate.error(res, index=2, main=c("_2 weighted histogram"), Qval=res[1,,c(4,5)]) 27 | x2boot <- compute.boots(res, index=2, Qval=res[1,,c(4,5)]) 28 | 29 | Mpi <- estimate.error(res, index=3, main=c("Mpi weighted histogram"), Qval=res[1,,c(4,5)], piononly=TRUE) 30 | Mpiboot <- compute.boots(res, index=3, Qval=res[1,,c(4,5)], piononly=TRUE) 31 | 32 | save(x1, x2, Mpi, file=paste("final-res.averx.", ens, ".Rdata", sep="")) 33 | 34 | if(!interactive()) dev.off() 35 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # Version 3.3.1 2 | 3 | * improvements of PGEVM for periodic correlators 4 | * added a double bootstrap routine for 'cf' called 5 | double_bootstrap.cf 6 | * added a new interface for 'gevp.hankel' which evaluates as a function 7 | of 'n', the matrix size. The new interface is called 8 | 'bootstrap.pgevm', which also acts on the double bootstrap data, if available 9 | * 'pgevm2effectivemass' can also deal with the double bootstrap data 10 | to estimate the uncertainty for the media. 11 | * added the oblique Lanczos method 'bootstrap.lanczos' for the 12 | analysis of Euclidean correlation functions 13 | 'bootstrap.lanczos' also works with double bootstrap 14 | * 'gevp.hankel' received some more functionality 15 | * 'plot.effectivemass' has a new optional parameter 'xshift' to shift 16 | data points in x-direction for legibility. 17 | 18 | # Version 3.2.1 19 | 20 | * fix problems in 'configure.ac' 21 | Now it should also work on Mac 22 | 23 | # Version 3.2.0 24 | 25 | * fix problems with roxygen docu in 'correlators_key_meson_3pt' and 26 | 'cf_key_meson_3pt' 27 | * faster implementation of 'plotwitherror' 28 | * allow to plot a bootstrap nlsfit on top of existing plot 29 | * Add some tests for 'computeDisc' function 30 | 31 | -------------------------------------------------------------------------------- /R/getNxNmatrix.R: -------------------------------------------------------------------------------- 1 | getNxNmatrix <- function(Cor, T1, t, N=2) { 2 | C1 <- matrix(0., nrow=N, ncol=N) 3 | C1[1,1] = Cor[t] 4 | C1[1,2] = Cor[(t+T1)] 5 | C1[2,1] = Cor[(t+2*T1)] 6 | C1[2,2] = Cor[(t+3*T1)] 7 | if(N > 2) { 8 | C1[1,3] = Cor[(t+20*T1)] 9 | C1[3,1] = C1[1,3] 10 | C1[1,4] = Cor[(t+21*T1)] 11 | C1[4,1] = C1[1,4] 12 | C1[2,3] = Cor[(t+22*T1)] 13 | C1[3,2] = C1[2,3] 14 | C1[2,4] = Cor[(t+23*T1)] 15 | C1[4,2] = C1[2,4] 16 | C1[3,3] = Cor[(t+16*T1)] 17 | C1[3,4] = Cor[(t+17*T1)] 18 | C1[4,3] = C1[3,4] 19 | C1[4,4] = Cor[(t+19*T1)] 20 | } 21 | if(N > 4) { 22 | C1[5,5] = Cor[(t+12*T1)] 23 | C1[5,6] = Cor[(t+13*T1)] 24 | C1[6,5] = C1[5,6] 25 | C1[6,6] = Cor[(t+15*T1)] 26 | C1[1,5] = Cor[(t+4*T1)] 27 | C1[5,1] = C1[1,5] 28 | C1[1,6] = Cor[(t+5*T1)] 29 | C1[6,1] = C1[1,6] 30 | C1[2,5] = Cor[(t+6*T1)] 31 | C1[5,2] = C1[2,5] 32 | C1[2,6] = Cor[(t+7*T1)] 33 | C1[6,2] = C1[2,6] 34 | C1[3,5] = Cor[(t+28*T1)] 35 | C1[5,3] = C1[3,5] 36 | C1[3,6] = Cor[(t+29*T1)] 37 | C1[6,3] = C1[3,6] 38 | C1[4,5] = Cor[(t+30*T1)] 39 | C1[5,4] = C1[4,5] 40 | C1[4,6] = Cor[(t+31*T1)] 41 | C1[6,4] = C1[4,6] 42 | } 43 | return(invisible(C1)) 44 | } 45 | -------------------------------------------------------------------------------- /exec/scatteringlength/plot-ratios.R: -------------------------------------------------------------------------------- 1 | require(tikzDevice) 2 | 3 | tikz(paste("ratios.tex", sep=""), standAlone = TRUE, width=6, height=5) 4 | par(cex=.7, cex.lab=1.5, cex.axis=1.5) 5 | 6 | plot(NA, xlim=c(6,32), ylim=c(1.6,1.95), ylab=c("$R(t)$"), xlab=c("$t/a$")) 7 | 8 | datafilelist = c("A40.32/A40.32.14-26.ratio.dat", "A40.24/A40.24.12-18.ratio.dat", "A60.24/A60.24.12-18.ratio.dat", "A80.24/A80.24.11-23.ratio.dat", "B35.32/B35.32.17-24.ratio.dat") 9 | fitfilelist = c("A40.32/A40.32.16-31.ratiofit.dat", "A40.24/A40.24.14-23.ratiofit.dat", "A60.24/A60.24.14-23.ratiofit.dat", "A80.24/A80.24.14-23.ratiofit.dat", "B35.32/B35.32.18-31.ratiofit.dat") 10 | colours = c("red", "blue", "darkgreen", "navy", "orange") 11 | pchlist =c(21, 22, 23, 24, 25) 12 | ii <- c(1:5) 13 | 14 | for(i in c(1:length(datafilelist))) { 15 | data <- read.table(datafilelist[i]) 16 | plotwitherror(x=data$V1, y=data$V2, dy=data$V3, pch=pchlist[i], col=colours[i], bg=colours[i], rep=TRUE) 17 | fit <- read.table(fitfilelist[i]) 18 | lines(fit$V1, fit$V2, col=colours[i]) 19 | } 20 | legend("topright", legend=c("A40.32", "A40.24", "A60.24", "A80.24", "B35.32"), pch=pchlist[ii], col=colours[ii], pt.bg=colours[ii], bty="n", cex=1.5) 21 | 22 | dev.off() 23 | tools::texi2dvi(paste("ratios.tex", sep=""), pdf=T) 24 | -------------------------------------------------------------------------------- /exec/online_measurements_analysis_driver_template.R: -------------------------------------------------------------------------------- 1 | skip <- 0 2 | stat_skip <- 0 3 | 4 | L <- 48 5 | Time <- 96 6 | beta <- 1.778 7 | type <- "iwa" 8 | kappa <- 0.1394267 9 | mul <- 0.0025 10 | csw <- 1.69 11 | musigma <- 0.1246864 12 | mudelta <- 0.1315052 13 | 14 | evals <- 5 15 | cg_col <- 20 16 | 17 | boot.l <- 2 18 | boot.R <- 1000 19 | 20 | t1 <- 15 21 | t2 <- 42 22 | 23 | for( path in c("cB211a.25.48","cB211b.25.48") ){ 24 | analysis_online(type=type, beta=beta, L=L, Time=Time, kappa=kappa, mul=mul, 25 | t1=t1, t2=t2, csw=csw, musigma=musigma, mudelta=mudelta, 26 | skip=skip, 27 | stat_skip=stat_skip, 28 | addon="", title=FALSE, 29 | evals=evals, 30 | cg_col=cg_col, 31 | plotsize=4.5, 32 | rundir=path, 33 | boot.l=boot.l, boot.R=boot.R, method="all", 34 | acc=TRUE) 35 | try(analysis_gradient_flow(path=path, 36 | basename="gradflow", 37 | outputbasename=path, 38 | pl=TRUE, 39 | read.data=TRUE, 40 | skip=skip/4, 41 | scale=4, 42 | dbg=FALSE)) 43 | } 44 | 45 | -------------------------------------------------------------------------------- /tests/testthat/test_parlist.R: -------------------------------------------------------------------------------- 1 | context('parlist') 2 | 3 | test_that('parlist_1', { 4 | corr_matrix_size <- 1 5 | actual <- make_parlist(corr_matrix_size) 6 | target <- array(c(1, 1), dim = c(2, 1)) 7 | expect_equal(actual, target) 8 | }) 9 | 10 | test_that('parlist_4', { 11 | corr_matrix_size <- 4 12 | actual <- make_parlist(corr_matrix_size) 13 | target <- array(c(1, 1, 1, 2, 2, 1, 2, 2), dim = c(2, 4)) 14 | expect_equal(actual, target) 15 | }) 16 | 17 | test_that('parind_1', { 18 | corr_matrix_size <- 1 19 | length_time <- 3 20 | parlist <- make_parlist(corr_matrix_size) 21 | actual <- make_parind(parlist, length_time) 22 | 23 | elements <- c(rep(c(2, 2), each = length_time)) 24 | target <- array(elements, dim = c(length_time, 2)) 25 | 26 | expect_equal(actual, target) 27 | }) 28 | 29 | test_that('parind_4', { 30 | corr_matrix_size <- 4 31 | length_time <- 7 32 | parlist <- make_parlist(corr_matrix_size) 33 | actual <- make_parind(parlist, length_time, summands = 1) 34 | 35 | elements <- c(rep(c(2, 2, 3, 3, 2, 3, 2, 3), each = length_time)) 36 | target <- array(elements, dim = c(corr_matrix_size * length_time, 2)) 37 | expect_equal(actual, target) 38 | 39 | actual <- make_parind(parlist, length_time, summands = 2) 40 | target <- cbind(target, target + 2) 41 | expect_equal(actual, target) 42 | }) 43 | -------------------------------------------------------------------------------- /exec/rho-phaseshift/infile-fit.delta.R: -------------------------------------------------------------------------------- 1 | #args <- list( 2 | # ens = c("A40.24", "A40.32"), 3 | # all.dirs = list( 4 | ## A40.20 = c("p0/T1u", "p1/A1g"), 5 | # A40.24 = c("p0/T1u", "p1/A1g", "p1/Ep1g"), 6 | # A40.32 = c("p0/T1u", "p1/A1g", "p1/Ep1g") 7 | # ), 8 | # pcs = list( 9 | ## A40.20 = c(1,3), 10 | # A40.24 = c(2,3,2), 11 | # A40.32 = c(2,3,2) 12 | # ), 13 | # data.paths = c("/hiskp2/werner/pipi_I1/data/A40.24/5_fit-data/", "/hiskp2/werner/pipi_I1/data/A40.32/5_fit-data/"), 14 | ## data.paths = c("/hiskp2/werner/pipi_I1/data/A40.20/5_fit-data/", "/hiskp2/werner/pipi_I1/data/A40.24/5_fit-data/", "/hiskp2/werner/pipi_I1/data/A40.32/5_fit-data/"), 15 | # output.path = "/hiskp2/werner/pipi_I1/data/A40" 16 | ## boot.R = 150, 17 | # ) 18 | 19 | args <- list( 20 | ens = c("A30.32"), 21 | all.dirs = list( 22 | # A30.32 = c("p0/T1u", "p1/A1", "p1/E", "p2/A1", "p2/B1", "p2/B2", "p3/A1", "p3/E", "p4/A1", "p4/E") 23 | A30.32 = c("p1/A1", "p1/E", "p2/A1", "p2/B1", "p2/B2", "p3/A1", "p3/E", "p4/A1", "p4/E") 24 | ), 25 | pcs = list( 26 | # A30.32 = c(3,3,2,3,2,2,2,1,1,1) 27 | A30.32 = c(3,2,3,2,2,2,1,1,1) 28 | ), 29 | data.paths = c("/hiskp4/werner/pipi_I1/data/A30.32/5_fit-data/"), 30 | output.path = "/hiskp4/werner/pipi_I1/data/A30.32" 31 | # boot.R = 150, 32 | ) 33 | 34 | -------------------------------------------------------------------------------- /R/functional.R: -------------------------------------------------------------------------------- 1 | #' Folds the non-empty list with the binary function 2 | #' 3 | #' A right fold without the need for a neutral element. Does not work with 4 | #' empty lists. 5 | #' 6 | #' @param f `function`. A binary function that takes two elements of the type 7 | #' contained in `xs` and returns another such element. 8 | #' @param xs `list` or vector. Homogenious list or vector of elements. 9 | #' 10 | #' There is a `Reduce` function in base R that does left and right folds. It 11 | #' always needs a starting element, which usually is the neutral element with 12 | #' respect to the binary operation. We do not want to specify such a neutral 13 | #' element for certain operations, like `+.cf`. Still a functional programming 14 | #' style should be supported such that one can use maps and folds. 15 | #' 16 | #' @export 17 | #' 18 | #' @examples 19 | #' # We generate some random numbers. 20 | #' numbers <- rnorm(10) 21 | #' 22 | #' # The sum is easiest computed with the `sum` function: 23 | #' sum(numbers) 24 | #' 25 | #' # If we wanted to implement `sum` ourselves, we can use a right fold to do 26 | #' # so: 27 | #' Reduce(`+`, numbers, 0.0) 28 | #' 29 | #' # With this new function we do not need a neutral element any more, but give 30 | #' # up the possibility to fold empty lists. 31 | #' foldr1(`+`, numbers) 32 | foldr1 <- function (f, xs) { 33 | l <- length(xs) 34 | stopifnot(l > 0) 35 | 36 | if (l == 1) 37 | return (xs[[1]]) 38 | else 39 | return (Reduce(f, xs[2:l], xs[[1]])) 40 | } 41 | -------------------------------------------------------------------------------- /tests/testthat/test_extractSingleCor_cf.R: -------------------------------------------------------------------------------- 1 | context('extractSingleCor.cf') 2 | 3 | test_that('extract_symmetrized', { 4 | ## We generate some different correlators from the data that we already have. 5 | samplecf_boot <- bootstrap.cf(samplecf) 6 | cf1 <- mul.cf(samplecf_boot, 5.39) 7 | cf2 <- mul.cf(samplecf_boot, 1.48) 8 | cf3 <- mul.cf(samplecf_boot, 3.09) 9 | 10 | ## We glue them together and extract the second one again. 11 | corr <- c(cf1, cf2, cf3) 12 | ex2 <- extractSingleCor.cf(corr, 2) 13 | 14 | expect_equal(ex2$cf, cf2$cf) 15 | expect_equal(ex2$cf0, cf2$cf0) 16 | expect_equal(ex2$cf.tsboot$t0, cf2$cf.tsboot$t0) 17 | expect_equal(ex2$cf.tsboot$t, cf2$cf.tsboot$t) 18 | }) 19 | 20 | test_that('extract_symmetrized', { 21 | ## We generate some different correlators from the data that we already have. 22 | ## `samplecf` is already symmetrized, so we need to let it forget about that. 23 | unsym <- samplecf 24 | unsym$Time <- ncol(unsym$cf) 25 | unsym$symmetrised <- FALSE 26 | samplecf_boot <- bootstrap.cf(unsym) 27 | cf1 <- mul.cf(samplecf_boot, 5.39) 28 | cf2 <- mul.cf(samplecf_boot, 1.48) 29 | cf3 <- mul.cf(samplecf_boot, 3.09) 30 | 31 | ## We glue them together and extract the second one again. 32 | corr <- c(cf1, cf2, cf3) 33 | ex2 <- extractSingleCor.cf(corr, 2) 34 | 35 | expect_equal(ex2$cf, cf2$cf) 36 | expect_equal(ex2$cf0, cf2$cf0) 37 | expect_equal(ex2$cf.tsboot$t0, cf2$cf.tsboot$t0) 38 | expect_equal(ex2$cf.tsboot$t, cf2$cf.tsboot$t) 39 | }) 40 | -------------------------------------------------------------------------------- /tests/single_constant_model.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Single Constant Model Test" 3 | author: "Martin Ueding" 4 | date: "7 1 2020" 5 | output: pdf_document 6 | --- 7 | 8 | ```{r setup, include=FALSE} 9 | knitr::opts_chunk$set(echo = TRUE) 10 | 11 | devtools::load_all() 12 | ``` 13 | 14 | ```{r} 15 | offset_val <- 50 16 | offset_err <- 0.1 17 | offset_matrix <- matrix( 18 | rnorm(nrow(samplecf$cf) * ncol(samplecf$cf), offset_val, offset_err), 19 | nrow = nrow(samplecf$cf), 20 | ncol = ncol(samplecf$cf)) 21 | 22 | samplecf_offset <- samplecf 23 | samplecf_offset$cf <- samplecf$cf + offset_matrix 24 | 25 | samplecf_boot <- bootstrap.cf(samplecf) 26 | samplecf_offset_boot <- bootstrap.cf(samplecf_offset) 27 | ``` 28 | 29 | ```{r} 30 | plot(samplecf_boot, col = 'blue') 31 | plot(samplecf_offset_boot, col = 'red', rep = TRUE) 32 | ``` 33 | 34 | ```{r} 35 | effmass <- bootstrap.effectivemass(samplecf_boot) 36 | effmass_offset <- bootstrap.effectivemass(samplecf_offset_boot) 37 | ``` 38 | 39 | ```{r} 40 | plot(effmass_offset, col = 'red') 41 | plot(effmass, col = 'blue', rep = TRUE) 42 | ``` 43 | 44 | ```{r} 45 | fit <- new_matrixfit(samplecf_boot, 8, 20) 46 | plot(fit, log = 'y') 47 | residual_plot(fit) 48 | ``` 49 | 50 | ```{r} 51 | fit_offset <- new_matrixfit(samplecf_offset_boot, 8, 20) 52 | plot(fit_offset, log = 'y') 53 | residual_plot(fit_offset) 54 | ``` 55 | 56 | ```{r} 57 | fit_offset2 <- new_matrixfit(samplecf_offset_boot, 8, 20, model = 'single_constant') 58 | plot(fit_offset2, log = 'y') 59 | residual_plot(fit_offset2) 60 | ``` -------------------------------------------------------------------------------- /R/deriv_utils.R: -------------------------------------------------------------------------------- 1 | #' @title create list of chains of displacements 2 | #' Multilpe covariant displacements, when applied in order, form 3 | #' a list of displacments. Each consists of a direction and a dimension. 4 | #' @param max_depth Positive integer, number of displacement combinations 5 | #' to construct. 6 | #' @param dims Integer vector, which lattice dimensions to consider. Default 0:3 7 | #' @param dirs Integer vector, which displacement directions to consider. Default 8 | #' forward and backward <-> c(0,1) 9 | #' @return List of data frames, each with columns 'dim' and 'dir' of 'max_depth' rows. 10 | create_displ_chains <- function(max_depth, dims=c(0:3), dirs=c(0,1) ){ 11 | stopifnot(max_depth > 0) 12 | # there are 4 dimensions, 2 directions 13 | # -> factor of 8 per level 14 | # -> in general, length(dims)*length(dirs) per level 15 | n_chains <- (length(dims)*length(dirs))^max_depth 16 | 17 | displ <- list() 18 | for( i in 1:max_depth ){ 19 | displ[[length(displ)+1]] <- dims 20 | } 21 | for( i in 1:max_depth ){ 22 | displ[[length(displ)+1]] <- dirs 23 | } 24 | 25 | displ_table <- as.matrix(expand.grid(displ)) 26 | colnames(displ_table) <- NULL 27 | rownames(displ_table) <- NULL 28 | dimnames(displ_table) <- NULL 29 | 30 | displ_chains <- list() 31 | for( i in 1:n_chains ){ 32 | displ_chains[[i]] <- data.frame(dim=displ_table[i, 1:max_depth], 33 | dir=displ_table[i, (max_depth+1):(2*max_depth)]) 34 | } 35 | 36 | return(displ_chains) 37 | 38 | } 39 | 40 | -------------------------------------------------------------------------------- /exec/analyse.pion0.2x2.R: -------------------------------------------------------------------------------- 1 | files <- getorderedfilelist(basename="disc.0.13872.0.003.k0v.", last.digits=3) 2 | vdata <- readcmiloopfiles(files) 3 | save(vdata, file="vdata.Rdata") 4 | cat("read done\n") 5 | pi0loops <- extract.loop(vdata, obs=9) 6 | save(pi0loops, file="pi0loops.Rdata") 7 | cat("extract done\n") 8 | ## local-local 9 | pi0disc.ll <- computeDisc(pi0loops, smeared=FALSE, real=TRUE, subtract.vev=TRUE) 10 | ## local-fuzzed 11 | pi0disc.lf <- computeDisc(cf = pi0loops, cf2 = pi0loops, smeared=FALSE, smeared2=TRUE, real=TRUE, subtract.vev=TRUE) 12 | ## pi0disc.fl per construction equal to pi0disc.lf 13 | ## fuzzed-fuzzed 14 | pi0disc.ff <- computeDisc(pi0loops, smeared=TRUE, real=TRUE, subtract.vev=TRUE) 15 | save(pi0disc.ll, file="pi0disc.ll.Rdata") 16 | save(pi0disc.lf, file="pi0disc.lf.Rdata") 17 | save(pi0disc.ff, file="pi0disc.ff.Rdata") 18 | #load("pi0disc.ll.Rdata") 19 | #load("pi0disc.lf.Rdata") 20 | #load("pi0disc.fl.Rdata") 21 | #load("pi0disc.ff.Rdata") 22 | 23 | files <- getorderedfilelist(basename="outprcvn.") 24 | cmicor <- readcmidatafiles(files) 25 | save(cmicor, file="neutral.Rdata") 26 | #load("neutral.Rdata") 27 | ## get the connected bit... 28 | pion0.con <- extract.obs(cmicor, vec.obs=c(5)) 29 | ## get the disconnected bit as a concatenation... 30 | pion0.disc <- c(pi0disc.ll, pi0disc.lf, pi0disc.lf, pi0disc.ff) 31 | ## now add connected and disconnected bits... 32 | ## factors depend on your normalisation 33 | pion0.cor <- add.cf(pion0.con, pion0.disc, a=-0.5, b=2.) 34 | ## bootstrap the correlators 35 | pion0.cor <- bootstrap.cf(pion0.cor, boot.R=400, boot.l=1) 36 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Hadron 2 | 3 | An R implementation of fitting routines used in lattice QCD. It provides useful 4 | functions for extraction hadronic quantities and such like. 5 | 6 | The license is *GPL 3 or later*, even though the `DESCRIPTION` only shows 7 | `GPL-3`. 8 | 9 | [master branch](https://github.com/HISKP-LQCD/hadron): [![Build Status](https://travis-ci.org/HISKP-LQCD/hadron.svg?branch=master)](https://travis-ci.org/HISKP-LQCD/hadron) 10 | 11 | # Installation 12 | 13 | First clone `hadron` from github, e.g. 14 | 15 | ```{sh} 16 | git clone https://github.com/HISKP-LQCD/hadron.git 17 | ``` 18 | 19 | Then change into the directory 20 | 21 | ```{sh} 22 | cd hadron 23 | ``` 24 | 25 | `hadron` can be installed using the `install` script 26 | provided. However, first the two packages `devtools` and `roxygen2` 27 | need to be installed. Start `R` by typing 28 | 29 | ```{sh} 30 | R 31 | ``` 32 | 33 | and then install the packages via 34 | 35 | ```{r} 36 | install.packages(c("devtools", "roxygen2"), dependencies=TRUE) 37 | ``` 38 | 39 | following the instructions. `hadron` itself also depends on a few 40 | libraries which can be installed as 41 | 42 | ```{r} 43 | install.packages(c("Rcpp", "abind", "boot", "dplyr", "R6", "stringr"), dependencies=TRUE) 44 | ``` 45 | 46 | Thereafter, `hadron` can finally be installed from the linux command line 47 | 48 | ```{sh} 49 | ./install 50 | ``` 51 | 52 | in the directory `hadron` was cloned into. 53 | 54 | Alternatively, you may use the `install_github` function of the 55 | `devtools` package to directly install from the github repository. 56 | -------------------------------------------------------------------------------- /exec/averx/perform-fits.R: -------------------------------------------------------------------------------- 1 | boot.R <- 1500 2 | boot.l <- 1 3 | seed <- 123476 4 | 5 | useCov <- TRUE 6 | ens <- c("cA2.09.48") 7 | 8 | tlower <- seq(4,20,2) 9 | tupper <- seq(28,44,2) 10 | piontlower <- seq(8,20,2) 11 | piontupper <- c(44,46,48) 12 | redo <- FALSE 13 | 14 | if(file.exists("parameters.R")) { 15 | source("parameters.R") 16 | } 17 | 18 | filename <- paste("averx-data-", ens, ".Rdata", sep="") 19 | if(!file.exists(filename)) { 20 | data2pt <- bootstrap.cf(convert2cf(read.table("ppcorlikepoint.dat")), boot.R=boot.R, boot.l=boot.l, seed=seed) 21 | data3pt <- bootstrap.cf(mul.cf(convert2cf(read.table("momf2elikepoint.dat")), -1.), boot.R=boot.R, boot.l=boot.l, seed=seed) 22 | 23 | save(data2pt, data3pt, file=filename) 24 | } 25 | load(filename) 26 | for(piont1 in piontlower) { 27 | for(piont2 in piontupper) { 28 | pionfit <- matrixfit(data2pt, t1=piont1, t2=piont2, symmetrise=TRUE, useCov=useCov, 29 | matrix.size=1, parlist=array(c(1,1), dim=c(2,1))) 30 | for(t1 in tlower) { 31 | for(t2 in tupper) { 32 | filename <- paste("res.averx.t1", t1, ".t2", t2, ".piont1", piont1, ".piont2", piont2, ".", ens, ".Rdata", sep="") 33 | if(!file.exists(filename) && !redo) { 34 | res.averx <- averx(data3pt, data2pt, pionfit, boot.R=boot.R, boot.l=boot.l, piont1=piont1, piont2=piont2, t1=t1, t2=t2, useCov=useCov) 35 | 36 | summary(res.averx) 37 | plot(res.averx) 38 | 39 | 40 | save(res.averx, file=filename) 41 | } 42 | } 43 | } 44 | } 45 | } 46 | 47 | -------------------------------------------------------------------------------- /src/cdh.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | double g1(double x); 9 | int g1array(double *x, double *res, const int n); 10 | static R_INLINE void fscdh(double rev, 11 | double aLamb1, 12 | double aLamb2, 13 | double aLamb3, 14 | double aLamb4, 15 | double *aF0, 16 | double a_fm, 17 | int *L, 18 | double *ampiV, 19 | double *afpiV, 20 | const int n, 21 | double *mpiFV, 22 | double *fpiFV, 23 | const int printit, 24 | double *rtilde, 25 | const int incim6); 26 | 27 | static R_INLINE void fscdhnew(double rev, 28 | double aLamb1, 29 | double aLamb2, 30 | double aLamb3, 31 | double aLamb4, 32 | double aF0, 33 | int *L, 34 | double *ampiV, 35 | double *afpiV, 36 | double *a2B0mu, 37 | const int n, 38 | double *mpiFV, 39 | double *fpiFV, 40 | const int printit); 41 | -------------------------------------------------------------------------------- /vignettes/jackknife_cov_and_missing_values.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Jackknife Covariance and Missing Values" 3 | author: "Martin Ueding" 4 | output: 5 | rmarkdown::html_vignette 6 | 7 | vignette: > 8 | %\VignetteIndexEntry{Jackknife Covariance and Missing Values} 9 | %\VignetteEngine{knitr::rmarkdown} 10 | \usepackage[utf8]{inputenc} 11 | --- 12 | 13 | ```{r echo=FALSE} 14 | library(hadron) 15 | ``` 16 | 17 | # Missing column 18 | 19 | We create some data and replace one column with `NA`. 20 | 21 | ```{r} 22 | data <- matrix(rnorm(120), ncol = 10) 23 | data[, 3] <- NA 24 | print(data) 25 | ``` 26 | 27 | The covariance, with the implicit `use = 'everything'` will give us a “cross” of `NA` in the covariance matrix. 28 | 29 | ```{r} 30 | cov(data) 31 | ``` 32 | 33 | The jackknife covariance does the same thing. 34 | 35 | ```{r} 36 | jackknife_cov(data) 37 | ``` 38 | 39 | # Missing row 40 | 41 | When we have some `NA` values in a row, we have a conceptual problem with the jackknife as the width of the jackknife distribution is linked to the number of measurements. 42 | 43 | ```{r} 44 | data <- matrix(rnorm(120), ncol = 10) 45 | data[2, ] <- NA 46 | print(data) 47 | ``` 48 | 49 | Also here we get the same behavior by default: 50 | 51 | ```{r} 52 | cov(data) 53 | ``` 54 | 55 | ```{r} 56 | jackknife_cov(data) 57 | ``` 58 | 59 | When we use `complete`, we get the same thing as just dropping the `NA` rows. 60 | 61 | ```{r} 62 | cov(data, use = 'complete') 63 | ``` 64 | 65 | ```{r} 66 | all(cov(data, use = 'complete') == cov(data[complete.cases(data), ])) 67 | ``` 68 | 69 | With our jackknife function we get a failure, which should not happen! 70 | 71 | ```{r} 72 | jackknife_cov(data, na.rm = TRUE) 73 | ``` 74 | 75 | -------------------------------------------------------------------------------- /R/string2error.R: -------------------------------------------------------------------------------- 1 | #' string2error 2 | #' 3 | #' @description 4 | #' takes a string of the form "x(dx)", where dx are the error digits 5 | #' and returns a numeric vector c(x, y), where y is dx as a proper 6 | #' numeric value. 7 | #' 8 | #' @param x Input character string. 9 | #' 10 | #' @return a numeric vector with the first element the value and the 11 | #' second the error 12 | #' 13 | #' @details 14 | #' can be used in combination with \link{apply} 15 | #' 16 | #' @export 17 | #' @examples 18 | #' string2error("0.35667(25)") 19 | #' 20 | #' s <- c("0.35667(25)", "0.667(50)") 21 | #' apply(array(s, dim=c(1, length(s))), 2, string2error) 22 | #' 23 | string2error <- function (x) { 24 | if (is.na(x)) { 25 | return (c(NA, NA)) 26 | } 27 | stopifnot(is.character(x)) 28 | 29 | # We use a regular expression to match the whole string. This makes sure that 30 | # we reject strings that do not match the format. 31 | match <- stringr::str_match(x, '^([+-]?[\\d.]+)\\((\\d+)\\)$') 32 | stopifnot(all(dim(match) == c(1, 3))) 33 | first <- match[[1, 2]] 34 | second <- match[[1, 3]] 35 | 36 | value <- as.numeric(first) 37 | 38 | # We need to differentiate whether the number actually has a decimal point as 39 | # this changes the interpretation of the error. 40 | first_parts <- strsplit(first, '.', fixed = TRUE)[[1]] 41 | if (length(first_parts) == 1) { 42 | # There is no decimal point. Therefore the error is just to be taken as is. 43 | error <- as.numeric(second) 44 | } else { 45 | # There is a decimal point, therefore the error is to be scaled down by that 46 | # many digits. 47 | error <- as.numeric(second) * 10^(- nchar(first_parts[2])) 48 | } 49 | 50 | return(c(value, abs(error))) 51 | } 52 | -------------------------------------------------------------------------------- /exec/analyse.pion.2x2.R: -------------------------------------------------------------------------------- 1 | ## if the data is concatenated into a single file "pion.dat" already, use this 2 | cmicor <- readcmicor("pion.dat") 3 | ## otherwise you need this here for reading the single files 4 | ### files <- getorderedfilelist(basename="outprcv.") 5 | ### cmicor <- readcmidatafiles(files) 6 | 7 | ## now extract the gamma matrix combination of interest 8 | pion.cor <- extract.obs(cmicor, vec.obs=c(1)) 9 | ## which will extract gamma5 from the file for all smearings available 10 | pion.cor <- bootstrap.cf(pion.cor, boot.R=400, boot.l=1) 11 | 12 | ## now we can attempt a constrained fit to the matrix 13 | pion.cor.matrixfit <- matrixfit(pion.cor, t1=10, t2=23, symmetrise=TRUE, useCov=FALSE) 14 | ## compute the ps decay constant for the twisted mass case, need mu and kappa 15 | pion.cor.matrixfit <- computefps(pion.cor.matrixfit, mu1=0.003, kappa=0.13782) 16 | X11() 17 | plot(pion.cor.matrixfit, xlab=c("t/a"), ylab=c("C(t)")) 18 | summary(pion.cor.matrixfit) 19 | 20 | ## or an effective mass analysis of the correlators 21 | pion.cor.effectivemass <- bootstrap.effectivemass(pion.cor, type="acosh") 22 | pion.cor.effectivemass <- fit.effectivemass(pion.cor.effectivemass, t1=10, t2=23, useCov=TRUE) 23 | X11() 24 | plot(pion.cor.effectivemass, xlab=c("t/a"), ylab=c("aM")) 25 | summary(pion.cor.effectivemass) 26 | 27 | ## apply a GEVP analysis 28 | pion.cor.gevp <- bootstrap.gevp(pion.cor, t0=1) 29 | ## extract the first principal correlator 30 | pion.pc1 <- gevp2cf(pion.cor.gevp, id=1) 31 | ## which can now be treated like a bootstrapped correlation function 32 | pion.pc1.effectivemass <- bootstrap.effectivemass(cf=pion.pc1, type="acosh") 33 | pion.pc1.effectivemass <- fit.effectivemass(pion.pc1.effectivemass, t1=10, t2=23, useCov=TRUE) 34 | summary(pion.pc1.effectivemass) 35 | X11() 36 | plot(pion.pc1.effectivemass, xlab=c("t/a"), ylab=c("aM")) 37 | -------------------------------------------------------------------------------- /exec/old/cmfit.R: -------------------------------------------------------------------------------- 1 | cmfit <- function(fitpar, optim.func=NULL, optim.method="BFGS", optim.control=list(trace=0), 2 | gsl.prec=c(1.e-10,1.e-3), no.masses=1, 3 | Thalf, x, y, err, tr, N, fit.routine="gsl") { 4 | 5 | if(missing(fitpar)) { 6 | stop("Error, parameter list must be given!") 7 | } 8 | 9 | 10 | if(fit.routine == "gsl") { 11 | fit <- gsl_fit_correlator_matrix(par=fitpar, Thalf=Thalf, x=x, y=y, 12 | err=err, tr=tr, N=N, no_masses=no.masses, 13 | prec=c(1.e-10,1.e-3)) 14 | } 15 | else if(fit.routine == "optim") { 16 | fit <- optim(par=fitpar, fn=optim.func, method=optim.method, control=optim.control, Thalf=Thalf, 17 | x=x, y=y, err=err, tr=tr, N=N) 18 | 19 | } 20 | else { 21 | npar <- length(fitpar) 22 | parsave <- numeric(npar) 23 | for(i in 1:npar) parsave[i] <- fitpar[i] 24 | 25 | state <- .Call("multifit_cor", fitpar, Thalf, x, y, err, tr, prec, N, 500, no_masses) 26 | if(state[5] >= 0) { 27 | return(invisible(list(par=state[6:(npar+5)], value=state[1], 28 | convergence=state[5], counts = state[3], dof = state[4]))) 29 | } 30 | else if(state[5] < 0) { 31 | state <- .Call("multimin_cor", parsave, Thalf, x, y, err, tr, prec, N, 500, no_masses) 32 | if(state[5] >= 0) { 33 | return(invisible(list(par=state[6:(npar+5)], value=state[1], 34 | convergence=state[5], counts = state[3], dof = state[4]))) 35 | } 36 | if(state[5] < 0) { 37 | fit <- optim(par=parsave, fn=optim.func, method=optim.method, control=optim.control, Thalf=Thalf, 38 | x=x, y=y, err=err, tr=tr, N=N) 39 | } 40 | } 41 | } 42 | 43 | return(invisible(fit)) 44 | } 45 | -------------------------------------------------------------------------------- /R/h5utils.R: -------------------------------------------------------------------------------- 1 | #' @title get dataset from HDF5 file 2 | #' @param h5f HDF5 file opened with \code{rhdf5::H5Fopen} 3 | #' @param key String, full path to dataset. 4 | #' @param check_exists Boolean, check if key actually exists (keep in mind overhead). 5 | #' 6 | #' @return 7 | #' Returns the requested dataset, if successfully read from file. 8 | #' 9 | #' @export 10 | h5_get_dataset <- function(h5f, key, check_exists = TRUE) 11 | { 12 | rhdf5_avail <- requireNamespace("rhdf5") 13 | stopifnot( rhdf5_avail ) 14 | exists <- ifelse(check_exists, rhdf5::H5Lexists(h5f, key), TRUE) 15 | if( exists ){ 16 | h5d <- rhdf5::H5Dopen(h5f, key) 17 | rval <- rhdf5::H5Dread(h5d) 18 | rhdf5::H5Dclose(h5d) 19 | } else { 20 | stop(sprintf("Dataset %s could not be found!", key)) 21 | } 22 | return(rval) 23 | } 24 | 25 | #' @title check if group names exist in HDF5 file 26 | #' @description The group names in an HDF5 file are stored as full paths 27 | #' as well as a flat vector. It is thus possible to check 28 | #' if a particular set of group names exist in the file 29 | #' by parsing the \code{name} member of the output 30 | #' of \code{rhdf5::h5ls}. This function does just that. 31 | #' @param h5f HDF5 file handle openend with \code{rhdf5::H5Fopen} 32 | #' @param nms_to_find Vector of strings, group names (not full paths) which 33 | #' are to be located in the file. 34 | #' @return Vector of booleans of the same length as \code{nms_to_find} 35 | #' indicating whether the name at the same index position 36 | #' was located in the file. 37 | h5_names_exist <- function(h5f, nms_to_find){ 38 | rhdf5_avail <- requireNamespace("rhdf5") 39 | stopifnot( rhdf5_avail ) 40 | nms <- rhdf5::h5ls(h5f)$name 41 | unlist( lapply( nms_to_find, function(x){ x %in% nms } ) ) 42 | } 43 | 44 | -------------------------------------------------------------------------------- /exec/old/fit_fp.R: -------------------------------------------------------------------------------- 1 | # source(file="fit_fp.R") 2 | # 3 | # 4 | 5 | 6 | ## data 7 | mu <- c(0.0040 , 0.0064 , 0.0100 ) 8 | fpsr0 <- c(0.33939648 , 0.3669825 , 0.38985338) 9 | fpsr0err <- c(0.001451 , 0.0018203 , 0.00102620 ) 10 | 11 | ## now try and fit 12 | dummy <- data.frame(x=mu , y = fpsr0) 13 | 14 | ## chiral log function 15 | 16 | fpsLOG = function(f,slope,mu,lamb) { 17 | 18 | tmp <- f * ( 1 - ( slope * mu * log(slope * mu / lamb) ) / (4.0 * pi * f^2 )^2 ) 19 | 20 | return (tmp ) 21 | } 22 | 23 | 24 | fpslinear = function(f,slope,mu,lamb) { 25 | 26 | tmp <- f + slope * mu 27 | 28 | return (tmp ) 29 | } 30 | 31 | 32 | # 33 | # from my fits 34 | # 35 | 36 | 37 | fff <- function(mu) { 38 | 39 | return (fpsLOG(0.308944,120.834,mu,0.4) ) 40 | } 41 | 42 | 43 | out <- fff(mu) 44 | 45 | ## 46 | ## simple linear fit 47 | ## 48 | ##myFIT <- nls(fpsr0 ~ a*mu + b , start = list(a=1 , b =0 ) , weights = 1/fpsr0err^2 , trace = TRUE ) 49 | 50 | # cut off in the chiral log term 51 | lamb <- 0.8 52 | 53 | 54 | ###myFIT <- nls(fpsr0 ~ fpsLOG(f,slope,mu,lamb) , start = list(f=0.308 , slope =8 ) , weights = 1/fpsr0err^2 , trace = TRUE ) 55 | 56 | myFIT <- nls(fpsr0 ~ fpslinear(f,slope,mu,lamb) , start = list(f=0.308 , slope =8 ) , weights = 1/fpsr0err^2 , trace = TRUE ) 57 | 58 | 59 | 60 | summary(myFIT) 61 | 62 | fitted(myFIT) 63 | fP <- coef(myFIT)[1] 64 | print(fP) 65 | 66 | slopeP <- coef(myFIT)[2] 67 | print(slopeP) 68 | 69 | ##q() 70 | 71 | ##plot(myFIT) 72 | 73 | ##pp <- predict(myFIT) 74 | ##plot(pp) 75 | 76 | # 77 | # plot the fit function 78 | # 79 | 80 | xx_start <- 0.0 81 | xx_end <- 0.015 82 | tot <- 100 83 | delta <- ( xx_end - xx_start ) / tot 84 | 85 | xx <- xx_start 86 | 87 | for ( i in 1:tot ) { 88 | 89 | yy <- fpslinear(fP,slopeP,xx,lamb) 90 | 91 | ss <- c(xx,yy) 92 | print(ss) 93 | xx <- xx + delta 94 | } 95 | -------------------------------------------------------------------------------- /exec/scatteringlength/analysis.R: -------------------------------------------------------------------------------- 1 | source("../analyse_pipi.R") 2 | redo <- FALSE 3 | source("parameters.R") 4 | 5 | cargs <- commandArgs(trailingOnly = TRUE) 6 | if(length(cargs) > 0) { 7 | tr1 <- as.integer(cargs[1]) 8 | } 9 | 10 | if(length(cargs) > 1) { 11 | t1 <- as.integer(cargs[2]) 12 | } 13 | 14 | if(length(cargs) > 2) { 15 | tr2 <- as.integer(cargs[3]) 16 | } 17 | 18 | if(length(cargs) > 3) { 19 | t2 <- as.integer(cargs[4]) 20 | } 21 | 22 | 23 | cat("tr1 =", tr1, ", t1 =", t1, "\n") 24 | 25 | data <- read.pipidata(path=srcpath, T=T, Tformat=TRUE) 26 | if(!interactive()) pdf(onefile=TRUE, file=paste("L-analysis", t1, ".", t2, ".", tr1, ".", tr2, ".pdf", sep="")) 27 | 28 | data$pion.cor <- bootstrap.cf(data$pion.cor, boot.R=boot.R, boot.l=boot.l) 29 | data$pion.effmass <- bootstrap.effectivemass(data$pion.cor, boot.R=boot.R, boot.l=boot.l, type="solve") 30 | data$pion.effmass <- fit.effectivemass(data$pion.effmass, t1=t1, t2=t2, useCov=useCov) 31 | 32 | 33 | for(ta in c(tr1:tr2)) { 34 | if(tr2 - ta < 5) break 35 | if(file.exists(paste("data.", ens, ".", t1, ".", t2, ".tr1", ta, ".tr2", tr2, ".Rdata", sep="")) && !redo) { 36 | load(paste("data.", ens, ".", t1, ".", t2, ".tr1", ta, ".tr2", tr2, ".Rdata", sep="")) 37 | } 38 | else { 39 | pipi.data <- try(run.pipi.analysis.ratio(data, t1=t1, t2=t2, tr1=ta, tr2=tr2, ens=ens, L=L, boot.R=boot.R, boot.l=boot.l)) 40 | } 41 | 42 | if(!inherits(pipi.data, "try-error")) { 43 | meta.data <- list(ens=ens, T=T, L=L, srcpath=srcpath, t1=t1, t2=t2, tr1=ta, tr2=tr2) 44 | save(meta.data, pipi.data, file=paste("data.", ens, ".", t1, ".", t2, ".tr1", ta, ".tr2", tr2, ".Rdata", sep="")) 45 | 46 | summary(pipi.data) 47 | plot(pipi.data) 48 | } 49 | else { 50 | cat("Skiping combination", ta, "-", tr2, "due to non converging fit\n") 51 | } 52 | } 53 | 54 | if(!interactive()) dev.off() 55 | -------------------------------------------------------------------------------- /exec/scatteringlength/test-ratio.R: -------------------------------------------------------------------------------- 1 | T <- 64 2 | L <- 32 3 | type <- "log" 4 | 5 | E0 <- 0.1415 6 | E1 <- 0.2420 7 | deltaE <- 0.0050 8 | Epipi <- E0+E1+deltaE 9 | ddE <- E1-E0 10 | 11 | t <- c(0:(T/2)) 12 | 13 | Cpipi <- cosh(ddE*(t-T/2)) + cosh(Epipi*(t-T/2)) 14 | Cpi0 <- cosh(E0*(t-T/2)) 15 | Cpi1 <- cosh(E1*(t-T/2)) 16 | 17 | t <- c(0:(T/2-1)) 18 | tt <- t+1 19 | R1 <- ((Cpipi[tt]*exp(ddE*t)-Cpipi[tt+1]*exp(ddE*(t+1)))*exp(-ddE*t) )/( Cpi0[tt]^2 - Cpi0[tt+1]^2 ) 20 | R2 <- ((Cpipi[tt]*exp(ddE*t)-Cpipi[tt+1]*exp(ddE*(t+1)))*exp(-ddE*t) )/((Cpi0[tt]*Cpi1[tt]*exp(ddE*t)-Cpi0[tt+1]*Cpi1[tt+1]*exp(ddE*(t+1))) ) 21 | R3 <- ((Cpipi[tt]*exp(ddE*t)-Cpipi[tt+1]*exp(ddE*(t+1)))*exp(-ddE*t) )/( Cpi0[tt]*Cpi1[tt] - Cpi0[tt+1]*Cpi1[tt+1] ) 22 | R4 <- ((Cpipi[tt]*exp(ddE*t)-Cpipi[tt+1]*exp(ddE*(t+1)))*exp(-ddE*t) )/( (Cpi0[tt]^2 - Cpi0[tt+1]^2)*exp(-ddE) ) 23 | R1[T/2+1] <- NA 24 | R2[T/2+1] <- NA 25 | R3[T/2+1] <- NA 26 | R4[T/2+1] <- NA 27 | 28 | mR1 <- effectivemass.cf(cf=R1, Thalf=T/2, type=type) 29 | mR2 <- effectivemass.cf(cf=R2, Thalf=T/2, type=type) 30 | mR3 <- effectivemass.cf(cf=R3, Thalf=T/2, type=type) 31 | mR4 <- effectivemass.cf(cf=R4, Thalf=T/2, type=type) 32 | 33 | #tt <- c(0:(T/2)) 34 | #plot(tt, R1, log="y") 35 | #points(tt, R2, col="red") 36 | 37 | tikzfiles <- tikz.init(paste("testdata", sep=""),width=6,height=5) 38 | plot(NA, ylim=c(0.9,1.1), xlim=c(1,26), xlab=c("$t/a$"), ylab=c("$\\delta E_\\mathrm{ratio}/\\delta E_\\mathrm{true}$")) 39 | points((mR1-E1+E0)/deltaE, pch=21, col="black", bg="black") 40 | points(c(0:(T/2-1)), (mR2-E1+E0)/deltaE, col="red", bg="red", pch=22) 41 | points(c(0:(T/2-1)), mR3/deltaE, col="blue", bg="blue", pch=23) 42 | #points(c(0:(T/2-1)), (mR4-E1+E0)/deltaE, col="darkgreen") 43 | abline(h=1) 44 | legend("topleft", legend=c("$R_1$", "$R_2$", "$R_3$"), col=c("black", "red", "blue"), pt.bg=c("black", "red", "blue"), bty="n", pch=c(21,22,23)) 45 | 46 | tikz.finalize(tikzfiles=tikzfiles,clean=TRUE, crop=FALSE) 47 | 48 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | AC_INIT 2 | AC_CONFIG_SRCDIR([src/alpha_s.c]) 3 | 4 | # This is from example from "writing R extensions" 5 | # Now find the compiler and compiler flags to use 6 | #: ${R_HOME=`R RHOME`} 7 | #if test -z "${R_HOME}"; then 8 | # echo "could not determine R_HOME" 9 | # exit 1 10 | #fi 11 | #CC=`"${R_HOME}/bin/R" CMD config CC` 12 | #CXX=`"${R_HOME}/bin/R" CMD config CXX` 13 | #CFLAGS=`"${R_HOME}/bin/R" CMD config CFLAGS` 14 | #CPPFLAGS=`"${R_HOME}/bin/R" CMD config CPPFLAGS` 15 | 16 | ## Following lines kindly supplied by Dirk Eddelbuettel for the 17 | ## gsl package, which we took over 18 | ## Use gsl-config to find arguments for compiler and linker flags 19 | ## 20 | ## Check for non-standard programs: gsl-config(1) 21 | AC_PATH_PROG([GSL_CONFIG], [gsl-config]) 22 | ## If gsl-config was found, let's use it 23 | if test "${GSL_CONFIG}" != ""; then 24 | # Use gsl-config for header and linker arguments 25 | GSL_CFLAGS=`${GSL_CONFIG} --cflags` 26 | GSL_LIBS=`${GSL_CONFIG} --libs` 27 | CFLAGS="$CFLAGS $GSL_CFLAGS" # kindly supplied by Ray Brownrigg 28 | else 29 | AC_MSG_ERROR([gsl-config not found, is GSL installed?]) 30 | fi 31 | 32 | # Check for GSL Version 33 | AC_MSG_CHECKING([if GSL version >= 1.8]) 34 | AC_RUN_IFELSE([AC_LANG_SOURCE([[ 35 | #include 36 | #include 37 | #include 38 | #include 39 | int main() { 40 | #ifdef GSL_VERSION 41 | int major, minor; 42 | char *gslv = GSL_VERSION; 43 | if ((sscanf(gslv, "%d.%d", &major, &minor)) != 2) { 44 | exit (1); 45 | } 46 | exit( !( (major >= 2) || (major == 1 && minor >= 8 ) ) ); 47 | #else 48 | exit(1); 49 | #endif 50 | } 51 | ]])], 52 | [gsl_version_ok=yes], 53 | [gsl_version_ok=no], 54 | [gsl_version_ok=yes]) 55 | if test "${gsl_version_ok}" = no; then 56 | AC_MSG_ERROR([Need GSL version >= 1.8]) 57 | else 58 | AC_MSG_RESULT([yes]) 59 | fi 60 | 61 | AC_SUBST(GSL_CFLAGS) 62 | AC_SUBST(GSL_LIBS) 63 | 64 | AC_CONFIG_FILES([src/Makevars]) 65 | AC_OUTPUT() 66 | 67 | -------------------------------------------------------------------------------- /exec/scatteringlength/get_summary.R: -------------------------------------------------------------------------------- 1 | source("summary.R") 2 | source("fit_finite_range.R") 3 | 4 | ensembles <- c("A30.32", "A40.32", "A40.24", "A40.20", "A60.24", "A80.24", "A100.24", "B55.32", "D45.32", "B35.32", "B85.24") 5 | 6 | ## compute the errors for ratio and efm data 7 | ## requires to run get_summary-efm and get_summary-ratio first 8 | 9 | tres <- array(0, dim=c(length(ensembles),12)) 10 | 11 | for(i in c(1:length(ensembles))) { 12 | cat("processing ensemble", ensembles[i], "for combined error analysis\n") 13 | load(paste("liuming/", ensembles[i], "/", "res-efm.", ensembles[i], ".Rdata", sep="")) 14 | res.efm <- res 15 | dim.efm <- dim(res.efm) 16 | load(paste(ensembles[i], "/", "res.", ensembles[i], ".Rdata", sep="")) 17 | res.ratio <- res 18 | dim.ratio <- dim(res.ratio) 19 | n1 <- min(dim.efm[1], dim.ratio[1]) 20 | tmp <- array(0, dim=c(n1, dim.efm[2]+dim.ratio[2], dim.efm[3])) 21 | tmp[,c(1:dim.efm[2]),] <- res.efm[c(1:n1),,] 22 | tmp[,c((dim.efm[2]+1):(dim.efm[2]+dim.ratio[2])),] <- res.ratio[c(1:n1),,] 23 | 24 | if(!interactive()) pdf(onefile=TRUE, file=paste("whists.", ensembles[i], ".pdf", sep="")) 25 | tmp <- compute.error.piL(tmp) 26 | tres[i,] <- c(tmp$deltaE, tmp$a0, tmp$mpia0) 27 | if(!interactive()) dev.off() 28 | } 29 | 30 | res <- tres 31 | save(ensembles, res, file="res-allens.Rdata") 32 | write.table(cbind(ensembles, format(res[,c(1:4)], digits=3, scientific=FALSE)), sep=" & ", quote=FALSE, row.names=FALSE, col.names=c("ens", '$\\delta E$', '$d\\delta E$', '$d^-\\delta E$', '$d^+\\delta E$'), file="res-deltaE-allens.dat", eol=" \\\\ \n") 33 | write.table(cbind(ensembles, format(res[,c(9:12)], digits=3, scientific=FALSE)), sep=" & ", quote=FALSE, row.names=FALSE, col.names=c("ens", '$M_\\pi a_0$', '$dM_\\pi a_0$', '$d^-M_\\pi a_0$', '$d^+M_\\pi a_0$'), file="res-mpia0-allens.dat", eol=" \\\\ \n") 34 | 35 | rm(res) 36 | 37 | res.finite.range.fit <- fit.finite.range() 38 | 39 | save(res.finite.range.fit, file="res-finite-range-fit.Rdata") 40 | 41 | rm(res.finite.range.fit) 42 | 43 | -------------------------------------------------------------------------------- /exec/scatteringlength/test-data.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | tikzfiles <- tikz.init(paste("compare-em", sep=""),width=5,height=5) 4 | 5 | plot(NA, ylim=c(0.05,0.15), xlim=c(5,26.5), main="", xlab=c("$t/a$"), ylab=c("$aE_\\mathrm{eff}$")) 6 | 7 | plotwitherror(x=c(0:30), effmass[1,], apply(effmass, 2, sd), col="black", rep=TRUE) 8 | plotwitherror(x=c(0:30)+0.2, effmassR2[1,], apply(effmassR2, 2, sd), rep=TRUE, col="blue") 9 | plotwitherror(x=c(0:30)-0.2, effmass3[1,], apply(effmass3, 2, sd), rep=TRUE, col="red") 10 | plotwitherror(x=c(0:30)+0.4, effmassR3[1,], apply(effmassR3, 2, sd), rep=TRUE, col="darkgreen") 11 | legend("bottomleft", legend=c("$R_1, t_0=1$", "$R_2, t_0=1$", "$R_1, t_0=8$", "$R_2, t_0=8$"), bty="n", col=c("black", "blue", "red", "darkgreen"), pch=c(21,21,21,21)) 12 | legend("topleft", legend=c("$\\delta E$ from $R_1, t_0=1$"), lty=c(1), col=c("black"), bty="n") 13 | abline(h=dEres$opt.tsboot[1,2], col="black") 14 | 15 | tikz.finalize(tikzfiles=tikzfiles,clean=TRUE, crop=FALSE) 16 | 17 | tikzfiles <- tikz.init(paste("compare-ratio", sep=""),width=5,height=5) 18 | 19 | tt <- c((t0+1):(T/2)) 20 | shift <- 0.5 21 | if(mf) shift <- 0. 22 | 23 | plot(NA, xlab="$t/a$", ylab="$R_i$", log="y", ylim=c(0.05,1.1), xlim=c(8,32)) 24 | plotwitherror(x=tt-shift, y=dEres$Rpipi.tsboot[1,tt]/dEres$Rpipi.tsboot[1,9], dy=dEres$dRpipi[tt]/dEres$Rpipi.tsboot[1,9], rep=TRUE, col="black") 25 | plotwitherror(x=tt-shift+0.2, y=dEresR2$Rpipi.tsboot[1,tt]/dEresR2$Rpipi.tsboot[1,9], dy=dEresR2$dRpipi[tt]/dEresR2$Rpipi.tsboot[1,9], rep=TRUE, col="blue") 26 | plotwitherror(x=tt-shift-0.2, y=dEres3$Rpipi.tsboot[1,tt]/dEres3$Rpipi.tsboot[1,9], dy=dEres3$dRpipi[tt]/dEres3$Rpipi.tsboot[1,9], rep=TRUE, col="red") 27 | plotwitherror(x=tt-shift+0.4, y=dEresR3$Rpipi.tsboot[1,tt]/dEresR3$Rpipi.tsboot[1,9], dy=dEresR3$dRpipi[tt]/dEresR3$Rpipi.tsboot[1,9], rep=TRUE, col="darkgreen") 28 | 29 | legend("bottomleft", legend=c("$R_1, t_0=1$", "$R_2, t_0=1$", "$R_1, t_0=8$", "$R_2, t_0=8$"), col=c("black", "blue", "red", "darkgreen"), pch=c(21,21, 21, 21), bty="n") 30 | 31 | tikz.finalize(tikzfiles=tikzfiles,clean=TRUE, crop=FALSE) 32 | -------------------------------------------------------------------------------- /exec/scatteringlength/get_summary-efm.R: -------------------------------------------------------------------------------- 1 | source("summary.R") 2 | source("fit_finite_range.R") 3 | 4 | reread <- FALSE 5 | ensembles <- c("A30.32", "A40.32", "A40.24", "A40.20", "A60.24", "A80.24", "A100.24", "B55.32", "D45.32", "B35.32", "B85.24") 6 | ##ensembles <- c("A30.32", "A40.32", "A40.24", "A40.20", "A60.24", "A80.24", "A100.24", "B55.32", "D45.32") 7 | 8 | ## now for the effective mass data 9 | 10 | tres <- array(0, dim=c(length(ensembles),12)) 11 | 12 | for(i in c(1:length(ensembles))) { 13 | cat("processing ensemble", ensembles[i], "using effective masses\n") 14 | if(file.exists(paste("liuming/", ensembles[i], "/", "res-efm.", ensembles[i], ".Rdata", sep="")) && !reread) { 15 | load(paste("liuming/", ensembles[i], "/", "res-efm.", ensembles[i], ".Rdata", sep="")) 16 | } 17 | else { 18 | load(paste("liuming/", ensembles[i], "/", "res.pc1.TP0.Rdata", sep="")) 19 | source(paste("liuming/", ensembles[i], "/", "parameters.R", sep="")) 20 | res <- compile.efm.sldata(ens=ensembles[i], path=paste("liuming/", ensembles[i], "/", sep=""), data=res, L=L) 21 | } 22 | if(!interactive()) pdf(onefile=TRUE, file=paste("whists-efm.", ensembles[i], ".pdf", sep="")) 23 | tmp <- compute.error.piL(res) 24 | tres[i,] <- c(tmp$deltaE, tmp$a0, tmp$mpia0) 25 | if(!interactive()) dev.off() 26 | } 27 | res <- tres 28 | rm(tres) 29 | 30 | save(ensembles, res, file="res-efm-allens.Rdata") 31 | write.table(cbind(ensembles, format(res[,c(1:4)], digits=3, scientific=FALSE)), sep=" & ", quote=FALSE, row.names=FALSE, col.names=c("ens", '$\\delta E$', '$d\\delta E$', '$d^-\\delta E$', '$d^+\\delta E$'), file="res-deltaE-efm-allens.dat", eol=" \\\\ \n") 32 | write.table(cbind(ensembles, format(res[,c(9:12)], digits=3, scientific=FALSE)), sep=" & ", quote=FALSE, row.names=FALSE, col.names=c("ens", '$M_\\pi a_0$', '$dM_\\pi a_0$', '$d^-M_\\pi a_0$', '$d^+M_\\pi a_0$'), file="res-mpia0-efm-allens.dat", eol=" \\\\ \n") 33 | 34 | rm(res) 35 | 36 | res.finite.range.fit <- fit.finite.range(path=paste("liuming/", sep=""), type="-efm") 37 | 38 | save(res.finite.range.fit, file="res-finite-range-fit-efm.Rdata") 39 | 40 | rm(res.finite.range.fit) 41 | -------------------------------------------------------------------------------- /inst/new_matrixfit.Rmd: -------------------------------------------------------------------------------- 1 | ```{r setup} 2 | devtools::load_all() 3 | ``` 4 | 5 | ```{r} 6 | 7 | 8 | boot.R <- 100#100 # Hier muss angepasst werden! 9 | boot.l <- 400#400 # block length 10 | seed <- 1234 11 | 12 | #==============================# 13 | # Read in correlator files: # 14 | #==============================# 15 | 16 | read <- function(n_phi) { 17 | corr <- readtextcf(paste0('/home/schlage/Master/R/correlators_',n_phi,'_phi_phi4p.tsv'), Time = 24, skip = 4) # Hier muss angepasst werden! 18 | return(corr) 19 | } 20 | 21 | corr1 <- read(1) 22 | corr2 <- read(2) 23 | corr3 <- read(3) 24 | corr4 <- read(4) 25 | corr5 <- read(5) 26 | 27 | #==============================# 28 | # 1 particle corr: # 29 | #==============================# 30 | uw1 <- uwerr.cf(corr1) 31 | save(uw1, file = 'uw1.Rdata') 32 | uw2 <- uwerr.cf(corr2) 33 | save(uw2, file = 'uw2.Rdata') 34 | uw3 <- uwerr.cf(corr3) 35 | save(uw3, file = 'uw3.Rdata') 36 | ``` 37 | 38 | 39 | ```{r} 40 | samplecf_boot1 <- bootstrap.cf(corr1, boot.R = boot.R, boot.l = boot.l, seed = seed) 41 | shifted_corr1 <- takeTimeDiff.cf(samplecf_boot1) # Calculate the shifted correlator 42 | 43 | z1 <- new_matrixfit(shifted_corr1, 1, 9, fit.method = 'lm', model = 'shifted', sym.vec = 'sinh') 44 | print(z1) 45 | cat('\n') 46 | print(z1$par) 47 | print(z1$t0[1]) 48 | print(z1$t0[2]) 49 | 50 | samplecf_boot2 <- bootstrap.cf(corr2, boot.R = boot.R, boot.l = boot.l, seed = seed) 51 | shifted_corr2 <- takeTimeDiff.cf(samplecf_boot2) # Calculate the shifted correlator 52 | 53 | z2 <- new_matrixfit(shifted_corr2, 1, 9, fit.method = 'lm', model = 'shifted', sym.vec = 'sinh') 54 | print(z2) 55 | cat('\n') 56 | print(z2$par) 57 | print(z2$t0) 58 | 59 | parin <- c(z1$t0[1], z2$t0[2]) 60 | print(parin) 61 | 62 | samplecf_boot3 <- bootstrap.cf(corr3, boot.R = boot.R, boot.l = boot.l, seed = seed) 63 | shifted_corr3 <- takeTimeDiff.cf(samplecf_boot3) # Calculate the shifted correlator 64 | 65 | z3 <- new_matrixfit(shifted_corr3, 1, 5, fit.method = 'lm', model = 'n_particles', sym.vec = 'sinh', param_vec = parin) 66 | print(z3) 67 | cat('\n') 68 | print(z3$par) 69 | print(z3$t0) 70 | 71 | ``` 72 | -------------------------------------------------------------------------------- /src/tmcdh.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | 9 | #include 10 | #include 11 | 12 | const double N = 16. * M_PI * M_PI; 13 | const double fmGeV = 0.1973269631; 14 | 15 | double w(const double x, const double lambda) { 16 | return (exp(-sqrt(1. + x * x) * lambda)); 17 | } 18 | 19 | double complex Jb(const double complex x) { 20 | double complex sigma; 21 | 22 | if (cabs(x) < 1.e-10) { 23 | sigma = csqrt(1. - 4. / x); 24 | return ((sigma * clog((sigma - 1.) / (sigma + 1.)) + 2.) / N); 25 | } 26 | return (0. * I); 27 | } 28 | 29 | double complex Jb1(const double complex x) { 30 | double complex sigma; 31 | 32 | if (cabs(x) < 1.e-10) { 33 | sigma = csqrt(1. - 4. / x); 34 | return ((2. / x / sigma * clog((sigma - 1.) / (sigma + 1.)) - 1.) / N / x); 35 | } 36 | return (1. / 6. / N + 0. * I); 37 | } 38 | 39 | typedef struct { 40 | int n; 41 | int k; 42 | double lambda; 43 | } pars; 44 | 45 | double x1(double x, void *params_) { 46 | double complex K; 47 | double complex z = 2 * (1. + I * x); 48 | pars *params = (pars *)params_; 49 | 50 | if (params->n == 0) { 51 | K = Jb(z); 52 | } else { 53 | K = Jb1(z); 54 | } 55 | 56 | if (params->k % 2 == 0) { 57 | return (w(x, params->lambda) * pow(x, params->k) * cimag(K)); 58 | } 59 | return (w(x, params->lambda) * pow(x, params->k) * creal(K)); 60 | } 61 | 62 | void calc_R_int(double *R[], const double lambda) { 63 | double result, error; 64 | int i, j; 65 | gsl_function F; 66 | gsl_integration_workspace *w; 67 | pars params; 68 | const int intervals = 1000000; 69 | 70 | w = gsl_integration_workspace_alloc(intervals); 71 | F.function = &x1; 72 | F.params = (void *)¶ms; 73 | params.lambda = lambda; 74 | 75 | for (i = 0; i < 2; i++) { 76 | params.n = i; 77 | for (j = 0; j < 3; j++) { 78 | params.k = j; 79 | gsl_integration_qagi(&F, 0., 1.e-6, intervals, w, &result, &error); 80 | R[i][j] = N * result; 81 | } 82 | } 83 | 84 | gsl_integration_workspace_free(w); 85 | } 86 | -------------------------------------------------------------------------------- /R/zeta_zp.R: -------------------------------------------------------------------------------- 1 | ## Nf = 2 - Schema RI' 2 | 3 | 4 | #' Computes the running of Z_P from scale mu0 to scale mu2 5 | #' 6 | #' Computes the running of the renomalisation constant \eqn{Z_P} from scale 7 | #' \eqn{\mu_0}{mu0} to scale \eqn{\mu_2}{mu2} in the renomalisation schema RI' 8 | #' for \eqn{N_f=2}{Nf=2} only. The running is done using perturbation theory up 9 | #' to \eqn{\alpha_s**3}{alpha_s^3} order. The corresponding values of 10 | #' \eqn{\alpha_s}{alpha_s} at the scales \eqn{\mu_0}{mu0} and \eqn{\mu_2}{mu2} 11 | #' are needed as input, see \code{\link{alphas}}. 12 | #' 13 | #' 14 | #' @param zp0 initial value of \eqn{Z_P} 15 | #' @param alpha0 \eqn{\alpha_s}{alpha_s} at initial scale 16 | #' @param alpha2 \eqn{\alpha_s}{alpha_s} at final scale 17 | #' @param nl order in PT, range 0 to 3 18 | #' @return returns the value of Z_P at scale mu2 in the RI' scheme 19 | #' @author Carsten Urbach, \email{curbach@@gmx.de} 20 | #' @seealso \code{\link{alphas}} 21 | #' @examples 22 | #' 23 | #' al2 <- alphas(mu = 3.0, nl = 3, lam0 = 0.250, Nc = 3, Nf = 2) 24 | #' al0 <- alphas(mu = 2.0, nl = 3, lam0 = 0.250, Nc = 3, Nf = 2) 25 | #' zetazp(zp0 = 0.6, alpha0 = al0, alpha2 = al2, nl = 3) 26 | #' 27 | #' @export zetazp 28 | zetazp<- function(zp0, alpha0, alpha2, nl = 3) { 29 | 30 | ## alm <- alpha_s(mu = mu2, nl = nl, lam0 = lam0, Nc = Nc, Nf = Nf) 31 | ## al0 <- alpha_s(mu = mu0, nl = nl, lam0 = lam0, Nc = Nc, Nf = Nf) 32 | 33 | if(nl == 3) { 34 | cmu <- (alpha2)^(-12./29.) * (1. - 8.55727 * alpha2 - 125.423 * alpha2^2 - 3797.71 * alpha2^3) 35 | cm0 <- (alpha0)^(-12./29.) * (1. - 8.55727 * alpha0 - 125.423 * alpha0^2 - 3797.71 * alpha0^3) 36 | } 37 | else if(nl == 2) { 38 | cmu <- (alpha2)^(-12./29.) * (1. - 8.55727 * alpha2 - 125.423 * alpha2^2) 39 | cm0 <- (alpha0)^(-12./29.) * (1. - 8.55727 * alpha0 - 125.423 * alpha0^2) 40 | } 41 | else if(nl == 1) { 42 | cmu <- (alpha2)^(-12./29.) * (1. - 8.55727 * alpha2) 43 | cm0 <- (alpha0)^(-12./29.) * (1. - 8.55727 * alpha0) 44 | } 45 | else { 46 | cmu <- (alpha2)^(-12./29.) 47 | cm0 <- (alpha0)^(-12./29.) 48 | if(nl > 3 || nl < 0) { 49 | warning("zeta_zp used with nl > 3 or nl < 0, using nl=0\n") 50 | } 51 | } 52 | return(cmu/cm0*zp0) 53 | } 54 | -------------------------------------------------------------------------------- /exec/scatteringlength/gather-deltaE-values.R: -------------------------------------------------------------------------------- 1 | source("analyse_pipi.R") 2 | source("summary.R") 3 | 4 | ens <- c("A40.32", "A40.24", "A40.20") 5 | ensdir <- c("A40.32cont", "A40.24cont", "A40.20cont") 6 | filename <- c("Energies-contR2.Rdata") 7 | tablefile <- c("dEres-all-contR2.dat") 8 | 9 | ##ensdir <- c("A40.32lat", "A40.24lat", "A40.20lat") 10 | ##filename <- c("Energies-lat.Rdata") 11 | ##tablefile <- c("dEres-all-lat.dat") 12 | 13 | Llist <- c(32, 24, 20) 14 | irreplist <- c("A1", "E", "T2") 15 | tplist <- list(c("TP0", "TP1", "TP2", "TP3"), c("TP0"), c("TP0")) 16 | idlist <- list(c(2,2,2,2), c(2), c(1)) 17 | boot.R <- 1500 18 | R2 <- TRUE 19 | 20 | boot.data <- c() 21 | bdata <- array(0., dim=c(boot.R+1,2)) 22 | 23 | reslist <- c() 24 | Epi <- data.frame() 25 | Epipi <- data.frame() 26 | 27 | for(d in c(1:length(ens))) { 28 | path <- paste(ensdir[d], "/", sep="") 29 | L <- Llist[d] 30 | for(i in c(1:length(irreplist))) { 31 | irrep <- irreplist[i] 32 | for(t in c(1:length(tplist[[i]]))) { 33 | tp <- tplist[[i]][t] 34 | for(pc.id in c(1:idlist[[i]][t])) { 35 | mergeEnergies(irrep, ens[d], pc.id, tp, path=path, R2=R2) 36 | rl <- summariseEnergies(irrep, ens[d], pc.id, tp, path=path, R2=R2) 37 | Epipi <- rbind(Epipi, data.frame(ens=ens[d], irrep=i, frame=t, level=pc.id, L=L, E=rl$E[1], dE=rl$E[2], dmE=rl$E[3], dpE=rl$E[4], irrepname=irrep, tpname=tp)) 38 | Epi <- rbind(Epi, data.frame(ens=ens[d], irrep=i, frame=t, level=pc.id, L=L, E=rl$Mpi[1], dE=rl$Mpi[2], dmE=rl$Mpi[3], dpE=rl$Mpi[4], irrepname=irrep, tpname=tp)) 39 | bdata[,1] <- rl$Eboots 40 | bdata[,2] <- rl$Mpiboots 41 | boot.data <- cbind(boot.data, bdata) 42 | cat(boot.data[1,], "\n") 43 | reslist <- rbind(reslist, c(ens[d], irrep, tp, pc.id, L, rl$deltaE, rl$E)) 44 | } 45 | } 46 | } 47 | } 48 | 49 | print(Epipi) 50 | print(Epi) 51 | ## covariance matrix for Epipi 52 | save(Epipi, Epi, boot.data, file=filename) 53 | 54 | write.table(reslist, file=tablefile, quote=FALSE, sep=" ", row.names=FALSE, col.names=FALSE) 55 | 56 | -------------------------------------------------------------------------------- /R/prop_error.R: -------------------------------------------------------------------------------- 1 | # functions for simple error propagation 2 | 3 | compute_square <- function(x,name=NA,debug=FALSE) { 4 | rval <- list( val=x$val^2, 5 | dval=2*x$val*x$dval, 6 | name=name ) 7 | if(debug) { 8 | print(sprintf("compute_square: %s",as.character(name))) 9 | print(rval) 10 | } 11 | return(rval) 12 | } 13 | 14 | compute_sqrt <- function(x,name=NA,debug=FALSE){ 15 | nidx <- which( x$val < 0) 16 | if(length(nidx)>0){ 17 | x["val",nidx] <- abs(x["val",nidx]) 18 | warning(sprintf("compute_sqrt: Warning, negative value replaced by absolute value for %s!\n",name)) 19 | } 20 | rval <- list( val=sqrt(x$val), 21 | dval=0.5*x$dval/sqrt(x$val), 22 | name=name ) 23 | if(debug) { 24 | print(sprintf("compute_sqrt: %s",as.character(name))) 25 | print(rval) 26 | } 27 | return(rval) 28 | } 29 | 30 | compute_ratio <- function(dividend,divisor,name=NA,debug=FALSE) { 31 | rval <- list( val=dividend$val / divisor$val, 32 | dval=sqrt( (dividend$dval/divisor$val)^2 + (divisor$dval*dividend$val/divisor$val^2)^2 ), 33 | name=name ) 34 | if(debug) { 35 | print(sprintf("compute_ratio: %s",as.character(name))) 36 | print(rval) 37 | } 38 | return(rval) 39 | } 40 | 41 | compute_product <- function(a,b,name=NA,debug=FALSE) { 42 | rval <- list( val=a$val * b$val, 43 | dval=sqrt( (a$dval*b$val)^2 + (b$dval*a$val)^2 ), 44 | name=name ) 45 | if(debug) { 46 | print(sprintf("compute_product: %s",as.character(name))) 47 | print(rval) 48 | } 49 | return(rval) 50 | } 51 | 52 | compute_sum <- function(a,b,name=NA,debug=FALSE) { 53 | rval <- list( val=a$val + b$val, 54 | dval=sqrt( a$dval^2 + b$dval^2 ), 55 | name=name ) 56 | if(debug) { 57 | message(sprintf("compute_sum: %s\n",as.character(name))) 58 | print(rval) 59 | } 60 | return(rval) 61 | } 62 | 63 | compute_difference <- function(pos,neg,name=NA,debug=FALSE) { 64 | neg$val <- -neg$val 65 | rval <- compute_sum(a=pos,b=neg,name=name,debug=FALSE) 66 | if(debug) { 67 | message(sprintf("compute_difference: %s\n",as.character(name))) 68 | print(rval) 69 | } 70 | return(rval) 71 | } 72 | 73 | -------------------------------------------------------------------------------- /exec/scatteringlength/get_summary-ratio.R: -------------------------------------------------------------------------------- 1 | source("summary.R") 2 | 3 | ensembles <- c("A30.32", "A40.32", "A40.24", "A40.20", "A60.24", "A80.24", "A100.24", "B55.32", "D45.32", "B35.32", "B85.24") 4 | 5 | ## compute the errors for ratio data 6 | 7 | res <- array(0, dim=c(length(ensembles),24)) 8 | bootres <- array() 9 | 10 | for(i in c(1:length(ensembles))) { 11 | tmpres <- compile.ratio.sldata(ens=ensembles[i], path=paste(ensembles[i], "/", sep="")) 12 | if(i == 1) { 13 | R <- length(tmpres[,1,1]) 14 | bootres <- array(0, dim=c(R, length(ensembles), 6)) 15 | } 16 | else if(R != length(tmpres[,1,1])) { 17 | stop(paste("number of bootstrap samples for ensemble ", ensembles[i], " does not match\n"), sep="") 18 | } 19 | if(!interactive()) pdf(onefile=TRUE, file=paste("whists-ratio.", ensembles[i], ".pdf", sep="")) 20 | tmp <- compute.error.piL(tmpres) 21 | res[i,] <- c(tmp$deltaE, tmp$a0, tmp$mpia0, tmp$qcotdelta, tmp$Ecm, tmp$qsq) 22 | k <- 1 23 | for(j in c(1,2,3,7,8,9)) { 24 | bootres[,i,k] <- compute.boots(res=tmpres, index=j) 25 | k <- k+1 26 | } 27 | if(!interactive()) dev.off() 28 | } 29 | 30 | save(ensembles, res, bootres, file="res-ratio-allens.Rdata") 31 | write.table(cbind(ensembles, format(res[,c(1:4)], digits=3, scientific=FALSE)), sep=" & ", quote=FALSE, row.names=FALSE, col.names=c("ens", '$\\delta E$', '$d\\delta E$', '$d^-\\delta E$', '$d^+\\delta E$'), file="res-deltaE-ratio-allens.dat", eol=" \\\\ \n") 32 | write.table(cbind(ensembles, format(res[,c(9:12)], digits=3, scientific=FALSE)), sep=" & ", quote=FALSE, row.names=FALSE, col.names=c("ens", '$M_\\pi a_0$', '$dM_\\pi a_0$', '$d^-M_\\pi a_0$', '$d^+M_\\pi a_0$'), file="res-mpia0-ratio-allens.dat", eol=" \\\\ \n") 33 | write.table(cbind(ensembles, format(res[,c(13:16)], digits=3, scientific=FALSE)), sep=" & ", quote=FALSE, row.names=FALSE, col.names=c("ens", '$q\\cot\\delta_0$', '$dq\\cot\\delta_0$', '$d^-q\\cot\\delta_0$', '$d^+q\\cot\\delta_0$'), file="res-qcotdelta-ratio-allens.dat", eol=" \\\\ \n") 34 | write.table(cbind(ensembles, format(res[,c(21:24)], digits=3, scientific=FALSE)), sep=" & ", quote=FALSE, row.names=FALSE, col.names=c("ens", '$q^2$', '$dq^2$', '$d^-q^2$', '$d^+q^2$'), file="res-qsq-ratio-allens.dat", eol=" \\\\ \n") 35 | rm(res, bootres, tmp, tmpres) 36 | 37 | -------------------------------------------------------------------------------- /verify-exports: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | # -*- coding: utf-8 -*- 3 | 4 | # Copyright © 2020 Martin Ueding 5 | 6 | import argparse 7 | import re 8 | import glob 9 | 10 | 11 | def read_namespace(path): 12 | exports = [] 13 | export_patterns = [] 14 | 15 | with open(path) as f: 16 | for line in f: 17 | m = re.match(r'export\("?([^")]+)"?\)', line) 18 | if m: 19 | string = m.group(1) 20 | parts = re.split(r', ?', string) 21 | exports += parts 22 | 23 | m = re.match(r'exportPattern\("([^")]+)"\)', line) 24 | if m: 25 | export_patterns.append(m.group(1)) 26 | 27 | m = re.match(r'S3method\([`"]?(.+?)[`"]?, ?(.+?)\)', line) 28 | if m: 29 | exports.append('{}.{}'.format(m.group(1), m.group(2))) 30 | 31 | print('Found exports:\n ', exports, '\n') 32 | print('Found export patterns:\n ', export_patterns, '\n') 33 | 34 | exports.sort() 35 | export_patterns.sort() 36 | 37 | return exports, export_patterns 38 | 39 | 40 | def main(): 41 | options = _parse_args() 42 | 43 | manual_exports, manual_export_patterns = read_namespace('NAMESPACE.manual') 44 | auto_exports, auto_export_patterns = read_namespace('NAMESPACE') 45 | 46 | def_pattern = re.compile(r'^\'?(\S+?)\'? ?<- ?function') 47 | available = [] 48 | 49 | for path in glob.glob('R/*.R'): 50 | with open(path) as f: 51 | for line in f: 52 | m = def_pattern.match(line) 53 | if m: 54 | available.append(m.group(1)) 55 | 56 | available.sort() 57 | 58 | print('Available functions:\n ', available, '\n') 59 | 60 | for func in available: 61 | if func not in manual_exports: 62 | for pattern in manual_export_patterns: 63 | m = re.match(pattern, func) 64 | if m: 65 | manual_exports.append(func) 66 | 67 | manual_exports.sort() 68 | auto_exports.sort() 69 | 70 | print('Manual exports:\n ', manual_exports, '\n') 71 | print('Auto exports:\n ', auto_exports, '\n') 72 | 73 | diff = list(sorted(set(manual_exports) - set(auto_exports))) 74 | 75 | print('Set difference:\n') 76 | for x in diff: 77 | print('- `{}`'.format(x)) 78 | 79 | 80 | def _parse_args(): 81 | parser = argparse.ArgumentParser(description='') 82 | options = parser.parse_args() 83 | 84 | return options 85 | 86 | 87 | if __name__ == '__main__': 88 | main() 89 | -------------------------------------------------------------------------------- /exec/phaseshift/pipi.R: -------------------------------------------------------------------------------- 1 | ## matrix size: N 2 | ## tp: reference frame 3 | energies.pipi <- function(N=5, tp="TP0", irrep="A1", basename="pipi_pipi_", redofit=TRUE, N.ids=3, 4 | t1 = c(10, 8, 5), t2 = c(31, 15, 13), seed=12345, t0=1, 5 | boot.R=400, boot.l=1, T=64, 6 | srcpath="./", path="./", ens, ind.vector=c(2,3)) { 7 | 8 | 9 | ## read data into Cmatrix 10 | if(!file.exists(paste(path, "Cmatrix.", irrep, ".", tp, ".Rdata", sep=""))) { 11 | Cmatrix <- cf() 12 | 13 | for(i in c(1:N)) { 14 | for(j in c(1:N)) { 15 | filename <- paste(basename, irrep, "_corr_", tp, "_", i-1, j-1, ".dat", sep="") 16 | tmp <- readtextcf(filename, T=T, check.t=1, path=srcpath, ind.vector=ind.vector) 17 | Cmatrix <- c(Cmatrix, tmp) 18 | } 19 | } 20 | 21 | ## we bootstrap the matrix and save 22 | Cmatrix <- bootstrap.cf(Cmatrix, boot.R=boot.R, boot.l=boot.l, seed=seed) 23 | save(Cmatrix, file=paste(path,"Cmatrix.", irrep, ".", tp, ".Rdata", sep="")) 24 | } 25 | load(file=paste(path,"Cmatrix.", irrep, ".", tp, ".Rdata", sep="")) 26 | 27 | if(redofit) { 28 | cat("...solving the GEVP\n") 29 | ## we use element.order to bring the matrix into the right order 30 | Cmatrix.bootstrap.gevp <- bootstrap.gevp(Cmatrix, matrix.size=N, t0=t0, 31 | element.order=c(1:(N^2))) 32 | 33 | save(Cmatrix.bootstrap.gevp, file=paste(path, "Cmatrix.bootstrap.gevp.", irrep, ".", tp, ".Rdata", sep="")) 34 | ## extract the principal correlators 35 | ## determine masses from effective mass plus temporal state 36 | cat("...determining masses for pi pi states\n") 37 | for(i in c(1:N.ids)) { 38 | pc <- gevp2cf(Cmatrix.bootstrap.gevp, id=i) 39 | for(ta in c(t1[i]:t2[i])) { 40 | if(t2[i] - ta < 5) break 41 | pc.effectivemass <- fit.effectivemass(bootstrap.effectivemass(cf=pc, type="temporal"), t1=ta, t2=t2[i], useCov=TRUE) 42 | summary(pc.effectivemass) 43 | ## lets save all of them 44 | meta.data <- list(ens=ens, T=T, srcpath=srcpath, t1=ta, t2=t2[i], tp=tp, pcid=i, irrep=irrep) 45 | save(pc.effectivemass, meta.data, file=paste(path, "pc", i, ".", irrep, ".", tp, ".effectivemass.", ta, ".", t2[i], ".Rdata", sep="")) 46 | 47 | plot(pc.effectivemass, xlab=c("t/a"), ylab=c("Meff"), main=paste("pc", i, ".", irrep, ".", tp, ".effectivemass.", ta, ".", t2[i], "p=", pc.effectivemass$Qval, sep="")) 48 | } 49 | } 50 | } 51 | return(invisible(Cmatrix)) 52 | } 53 | 54 | -------------------------------------------------------------------------------- /exec/old/analyseOS.R: -------------------------------------------------------------------------------- 1 | analyse.os <- function(N, kappa, t1, t2, boot.R, boot.l, 2 | muvalues, ename, starti=0) { 3 | if(length(t1) == 1) { 4 | t1 <- rep(t1[1], times=((N+1)*(N+2)/2)) 5 | } 6 | else if(length(t1) != ((N+1)*(N+2)/2)) { 7 | stop("Error! t1 must be of lenght 1 or (N+1)*(N+2)/2!") 8 | } 9 | if(length(t2) == 1) { 10 | t2 <- rep(t2[1], times=((N+1)*(N+2)/2)) 11 | } 12 | else if(length(t2) != ((N+1)*(N+2)/2)) { 13 | stop("Error! t2 must be of lenght 1 or (N+1)*(N+2)/2!") 14 | } 15 | 16 | result <- data.frame(mu1 = numeric((N+1)*(N+2)/2), mu2 = numeric((N+1)*(N+2)/2), 17 | m = numeric((N+1)*(N+2)/2), dm = numeric((N+1)*(N+2)/2), 18 | f = numeric((N+1)*(N+2)/2), df = numeric((N+1)*(N+2)/2), 19 | fsinh = numeric((N+1)*(N+2)/2), L = numeric((N+1)*(N+2)/2), 20 | chisqr = numeric((N+1)*(N+2)/2), dof = numeric((N+1)*(N+2)/2), 21 | t1 = t1, t2 = t2) 22 | 23 | c <- 1 24 | bootsamples <- array(0., dim=c(boot.R, 2, (N+1)*(N+2)/2)) 25 | 26 | for (i in starti:N) { 27 | for (j in i:N) { 28 | mu1 <- muvalues$V1[i+1] 29 | mu2 <- muvalues$V1[j+1] 30 | filename=paste("ppcorrel.",sprintf("%.02d", i),".",sprintf("%.02d", j),".dat",sep="") 31 | cat(i, j, filename, "\n") 32 | cmicor <- read.table(filename, header=F, colClasse=c("integer","integer","integer","numeric","numeric")); 33 | res <- smearedpion(cmicor, t1=t1[c], t2=t2[c], debug=FALSE, method="all", mu1=mu1, mu2=mu2, kappa=kappa, boot.R=boot.R, boot.l=boot.l) 34 | result$L <- max(cmicor[3]) 35 | result$mu1[c] <- mu1 36 | result$mu2[c] <- mu2 37 | result$m[c] <- abs(res$fitresult$par[3]) 38 | result$dm[c] <- res$uwerrresultmps$dvalue 39 | result$f[c] <- 2*kappa*2*(mu1+mu2)/2/sqrt(2)*abs(res$fitresult$par[1])/sqrt(abs(result$m[c])^3) 40 | result$fsinh[c] <- 2*kappa*2*(mu1+mu2)/2/sqrt(2)*abs(res$fitresult$par[1])/sqrt(abs(result$m[c]))/sinh(abs(result$m[c])) 41 | result$df[c] <- res$uwerrresultfps$dvalue*2*kappa*2*(mu1+mu2)/2./sqrt(2) 42 | result$chisqr[c] <- res$fitresult$value 43 | result$dof[c] <- res$dof 44 | bootsamples[,1,c] <- res$tsboot$t[,1] 45 | bootsamples[,2,c] <- res$tsboot$t[,2] 46 | c <- c+1 47 | save(result, file=paste("result", ename, ".Rdata", sep="")) 48 | save(bootsamples, file=paste("bootsamples", ename, ".Rdata", sep="")) 49 | } 50 | } 51 | write.table(result, file=paste("result", ename, ".dat", sep=""), quote=FALSE, sep="\t") 52 | } 53 | -------------------------------------------------------------------------------- /exec/old/avercycle.R: -------------------------------------------------------------------------------- 1 | avercycle <- function(cmicor, cycle.l, ind.vec=c(1,3,4,5,6)) { 2 | Time <- 2*max(cmicor[,ind.vec[2]]) 3 | Thalf <- max(cmicor[,ind.vec[2]]) 4 | T1 <- Thalf+1 5 | nrObs <- max(cmicor[,ind.vec[1]]) 6 | Skip <- 0 7 | Length <- length(cmicor[,ind.vec[3]]) 8 | nrep <- c(length(cmicor[((Skip):Length),ind.vec[3]])/(nrObs*(T1)*4)) 9 | cat("total no of measurements", nrep, "\n") 10 | start.no <- min(cmicor[,6]) 11 | end.no <- max(cmicor[,6]) 12 | cat("first measurement no", start.no, "\n") 13 | cat("last measurement no", end.no, "\n") 14 | gauge.no <- cmicor[seq(from=1, to=(nrep*(nrObs*(T1)*4)), by=(nrObs*(T1)*4)), 6] 15 | cycle.no <- floor((end.no -start.no)/cycle.l) 16 | if((end.no -start.no)/cycle.l > cycle.no) cycle.no <- cycle.no+1 17 | cat("no of cycles is", cycle.no, "\n") 18 | cat("average cycle length", nrep/cycle.no, "\n") 19 | cycle.ind <- array(0, dim=c(3,cycle.no)) 20 | s <- start.no 21 | no.thiscycle <- 0 22 | c.no <- 1 23 | cycle.ind[2, 1] <- 1 24 | for(i in 1:nrep) { 25 | if(gauge.no[i] <= (s + cycle.l)) { 26 | no.thiscycle <- no.thiscycle+1 27 | } 28 | else { 29 | s <- s+cycle.l 30 | cycle.ind[1, c.no] <- no.thiscycle 31 | cycle.ind[3, c.no] <- i-1 32 | no.thiscycle <- 1 33 | # cat(c.no, cycle.ind[,c.no], "\n") 34 | c.no <- c.no + 1 35 | cycle.ind[2, c.no] <- i 36 | } 37 | if(i == nrep) { 38 | cycle.ind[1, c.no] <- no.thiscycle 39 | cycle.ind[3, c.no] <- i 40 | # cat(c.no, cycle.ind[,c.no], "\n") 41 | } 42 | } 43 | # cat("sum of measurements used", sum(cycle.ind[1,]), "(check!) \n") 44 | # newcor <- array(0., dim=c(cycle.no*(nrObs*(T1)*4), 6)) 45 | # ii <- c(1:3,6) 46 | 47 | # for(i in 1:cycle.no) { 48 | # for(j in 1:4) { 49 | # newcor[(i-1)*(nrObs*(T1)*4)+c(1:(nrObs*(T1)*4)), ii[j]] <- 50 | # cmicor[(cycle.ind[2, i]-1)*(nrObs*(T1)*4) + c(1:(nrObs*(T1)*4)), ii[j]] 51 | # } 52 | 53 | # for(k in 4:5) { 54 | # for(j in cycle.ind[2, i]:cycle.ind[3, i]) { 55 | # jj <- c(cycle.ind[2,i]:cycle.ind[3, i])-1 56 | ## for(p in 1:(nrObs*(T1)*4)) { 57 | ## newcor[(i-1)*(nrObs*(T1)*4)+p,k] <- sum(cmicor[p+jj*(nrObs*(T1)*4), k]) 58 | # newcor[(i-1)*(nrObs*(T1)*4)+c(1:(nrObs*(T1)*4)), k] <- 59 | # newcor[(i-1)*(nrObs*(T1)*4)+c(1:(nrObs*(T1)*4)), k] + 60 | # cmicor[(j-1)*(nrObs*(T1)*4) + c(1:(nrObs*(T1)*4)), k]/nrep*cycle.no 61 | 62 | 63 | # } 64 | # } 65 | # cat(".") 66 | # } 67 | # cat("\n") 68 | # gc(reset=TRUE) 69 | # return(invisible(newcor)) 70 | 71 | } 72 | -------------------------------------------------------------------------------- /exec/rho-phaseshift/plot-delta.R: -------------------------------------------------------------------------------- 1 | source("parameters.R") 2 | 3 | cframes <- toupper(frames) 4 | pch <- c(21, 22, 23, 24, 25) 5 | col <- c("red", "darkblue", "darkgreen", "purple", "orange", "black") 6 | 7 | load("pion.Rdata") 8 | Mpi <-pion.matrixfit$opt.res$par[1] 9 | 10 | tikzfiles <- tikz.init(basename=paste("delta-", ens[1], sep=""), width=5., height=4.) 11 | 12 | plot(NA, xlim=c(2*Mpi,4*Mpi), ylim=c(0,pi), xlab=c("$aE_\\mathrm{CM}$"), ylab=c("$\\delta\\,[\\mathrm{rad}]$")) 13 | 14 | for(e in ens) { 15 | for(f in frames) { 16 | if(f == "mf4") { 17 | file <- paste(toupper(f), "/res.", e, "mf1.Rdata", sep="") 18 | } 19 | else { 20 | file <- paste(toupper(f), "/res.", e, f, ".Rdata", sep="") 21 | } 22 | cat("loading file", file, "\n") 23 | load(file) 24 | i <- which(frames == f) 25 | arrows(res.all.pc1$Ecm[1], res.all.pc1$delta[1]+res.all.pc1$delta[3], 26 | res.all.pc1$Ecm[1], res.all.pc1$delta[1]+res.all.pc1$delta[4], length=0.01,angle=90,code=3, col="black", lwd=0.5) 27 | arrows(res.all.pc1$Ecm[1]+res.all.pc1$Ecm[3], res.all.pc1$delta[1], 28 | res.all.pc1$Ecm[1]+res.all.pc1$Ecm[4], res.all.pc1$delta[1], length=0.01,angle=90,code=3, col="black", lwd=0.5) 29 | plotwitherror(x=res.all.pc1$Ecm[1], dx=res.all.pc1$Ecm[2], y=res.all.pc1$delta[1], dy=res.all.pc1$delta[2], rep=TRUE, col=col[i], bg=col[i], pch=pch[1]) 30 | cat("Ecm1\t", res.all.pc1$Ecm[1], res.all.pc1$Ecm[2], res.all.pc1$Ecm[3], res.all.pc1$Ecm[4], "\n") 31 | cat("delta1\t", res.all.pc1$delta[1], res.all.pc1$delta[2], res.all.pc1$delta[3], res.all.pc1$delta[4], "\n") 32 | 33 | arrows(res.all.pc2$Ecm[1], res.all.pc2$delta[1]+res.all.pc2$delta[3], 34 | res.all.pc2$Ecm[1], res.all.pc2$delta[1]+res.all.pc2$delta[4], length=0.01,angle=90,code=3, col="black", lwd=0.5) 35 | arrows(res.all.pc2$Ecm[1]+res.all.pc2$Ecm[3], res.all.pc2$delta[1], 36 | res.all.pc2$Ecm[1]+res.all.pc2$Ecm[4], res.all.pc2$delta[1], length=0.01,angle=90,code=3, col="black", lwd=0.5) 37 | plotwitherror(x=res.all.pc2$Ecm[1], dx=res.all.pc2$Ecm[2], y=res.all.pc2$delta[1], dy=res.all.pc2$delta[2], rep=TRUE, col=col[i], bg=col[i], pch=pch[2]) 38 | cat("Ecm2\t", res.all.pc2$Ecm[1], res.all.pc2$Ecm[2], res.all.pc2$Ecm[3], res.all.pc2$Ecm[4], "\n") 39 | cat("delta2\t", res.all.pc2$delta[1], res.all.pc2$delta[2], res.all.pc2$delta[3], res.all.pc2$delta[4], "\n") 40 | } 41 | } 42 | 43 | legend("topleft", legend=toupper(frames), bty="n", text.col=col) 44 | legend("bottomright", legend=c("ground state","1st excited state"), bty="n", pch=pch[1:2], col="black", pt.bg="black") 45 | 46 | tikz.finalize(tikzfiles=tikzfiles) 47 | -------------------------------------------------------------------------------- /R/alpha_s.R: -------------------------------------------------------------------------------- 1 | #' compute alpha strong at given scale 2 | #' 3 | #' compute alpha strong (\eqn{\alpha_s}{alpha_s}) at given scale \eqn{\mu}{mu} 4 | #' up to N3LO in PT in the RI' renormalisation scheme. 5 | #' 6 | #' 7 | #' @param mu the renormalisation scale \eqn{\mu}{mu} in GeV 8 | #' @param nl order in PT, range 0 to 3 9 | #' @param lam0 \eqn{\Lambda_\mathrm{QCD}}{Lambda_QCD} in GeV 10 | #' @param Nc number of colours \eqn{N_c}{Nc}, defaults to 3 11 | #' @param Nf number of flavours \eqn{N_f}{Nf}, default is 2 12 | #' @param use.cimpl Use the C implementation instead of the R implementation, 13 | #' which might improve speed. 14 | #' @return returns the value of alpha strong \eqn{\alpha_s}{alpha_s} at scale 15 | #' \eqn{\mu}{mu} 16 | #' @author Carsten Urbach, \email{curbach@@gmx.de}, Vittorio Lubicz (of the original Fortran code) 17 | #' @seealso \code{\link{zetazp}} 18 | #' @examples 19 | #' 20 | #' alphas(mu=2.0, nl=3) 21 | #' 22 | #' @export alphas 23 | alphas <- function(mu, nl=3, lam0=0.250, Nc=3., Nf=2., use.cimpl=TRUE) { 24 | if(!use.cimpl) { 25 | return(alphas.R( mu, nl, lam0, Nc, Nf)) 26 | } 27 | return(.Call("alphas", mu, nl, lam0, as.numeric(Nc), as.numeric(Nf))) 28 | } 29 | 30 | 31 | alphas.R <- function(mu, nl, lam0, Nc, Nf) { 32 | 33 | Cf <- (Nc^2-1.)/2./Nc 34 | Z3 <- 1.20206 35 | 36 | b0 <- 11./3.*Nc - 2./3.*Nf 37 | b1 <- 34./3.*Nc^2 - 38./3.*Nf 38 | b2 <- 2857./54.*Nc^3 + Cf^2*Nf - 205./18.*Cf*Nc*Nf - 39 | 1415./54.*Nc^2*Nf + 11./9.*Cf*Nf^2 + 79./54.*Nc*Nf^2 40 | b3 <- (150653./486. - 44./9.*Z3)*Nc^4 + 41 | (-39143./162. + 68./3.*Z3)*Nc^3*Nf + 42 | (7073./486. - 328./9.*Z3)*Cf*Nc^2*Nf + 43 | (-2102./27. + 176./9.*Z3)*Cf^2*Nc*Nf + 44 | 23.*Cf^3*Nf + (3965./162. + 56./9.*Z3)*Nc^2*Nf^2 + 45 | (338./27. - 176./9.*Z3)*Cf^2*Nf^2 + 46 | (4288./243. + 112./9.*Z3)*Cf*Nc*Nf^2 + 53./243.*Nc*Nf^3 + 47 | 154./243.*Cf*Nf^3 + 48 | (-10./27. + 88./9.*Z3)*Nc^2*(Nc^2+36.) + 49 | (32./27. - 104./9.*Z3)*Nc*(Nc^2+6)*Nf + 50 | (-22./27. + 16./9.*Z3)*(Nc^4 - 6.*Nc^2 + 18.)/Nc^2*Nf^2 51 | 52 | b1 <- b1/b0/4./pi 53 | b2 <- b2/b0/16./pi^2 54 | b3 <- b3/b0/64./pi^3 55 | 56 | L2 <- log(mu^2/lam0^2) 57 | LL2 <- log(L2) 58 | 59 | als0 <- 4.*pi/b0/L2 60 | als1 <- als0 - als0^2*b1*LL2 61 | als2 <- als1 + als0^3*(b1^2*(LL2^2 - LL2 -1.) + b2) 62 | als3 <- als2 + als0^4*(b1^3*(-LL2^3+5./2.*LL2^2+2*LL2-1./2.)- 63 | 3.*b1*b2*LL2 + b3/2.) 64 | if(nl == 0) return(als0/(4.*pi)) 65 | if(nl == 1) return(als1/(4.*pi)) 66 | if(nl == 2) return(als2/(4.*pi)) 67 | return(als3/(4.*pi)) 68 | } 69 | -------------------------------------------------------------------------------- /exec/phaseshift/test-rootfinding.R: -------------------------------------------------------------------------------- 1 | source("phaseshift.R") 2 | 3 | Mpi <- 0.1414706 4 | L <- 32 5 | no <- 3 6 | 7 | par <- c(1./-1.2921363062, 14.2906242026, 1./-49.8148003974) 8 | 9 | q <- sqrt(c(seq(0.000001, .1, 0.00008), seq(0.100001, .25, 0.0002))) 10 | 11 | if(!file.exists("WCM.Rdata")) { 12 | WCM <- prepdetEqCMscan(q=q, L=L, Mpi=Mpi) 13 | save(WCM, file="WCM.Rdata") 14 | } 15 | load("WCM.Rdata") 16 | if(!file.exists("WMF1.Rdata")) { 17 | WMF1 <- prepdetEqMF1scan(q=q, L=L, Mpi=Mpi) 18 | save(WMF1, file="WMF1.Rdata") 19 | } 20 | load("WMF1.Rdata") 21 | if(!file.exists("WMF2.Rdata")) { 22 | WMF2 <- prepdetEqMF2scan(q=q, L=L, Mpi=Mpi) 23 | save(WMF2, file="WMF2.Rdata") 24 | } 25 | load("WMF2.Rdata") 26 | if(!file.exists("WMF3.Rdata")) { 27 | WMF3 <- prepdetEqMF3scan(q=q, L=L, Mpi=Mpi) 28 | save(WMF3, file="WMF3.Rdata") 29 | } 30 | load("WMF3.Rdata") 31 | rm(q) 32 | 33 | cat(par, "\n") 34 | cat("L = ", L, "\n") 35 | cat("Mpi = ", Mpi, "\n") 36 | ii <- findSignChanges(fn=detEqCMA1scan, par=par, makeplot=TRUE, W=WCM, no=no, threshold=10) 37 | zerosCM <- findZeros(fn=detEqCMA1, q=WCM$q, ii=ii, L=L, Mpi=Mpi, par=par, makeplot=TRUE) 38 | ECM <- Eofqsq(zerosCM, dvec=c(0,0,0), Mpi=Mpi,L=L) 39 | cat("CM A1", zerosCM, "\n") 40 | 41 | ii <- findSignChanges(fn=detEqCMEscan, par=par, makeplot=TRUE, W=WCM, no=no, threshold=1) 42 | zerosCME <- findZeros(fn=detEqCME, q=WCM$q, ii=ii, L=L, Mpi=Mpi, par=par, makeplot=TRUE) 43 | ECM <- Eofqsq(zerosCME, dvec=c(0,0,0), Mpi=Mpi,L=L) 44 | cat("CM E", zerosCME, "\n") 45 | cat("energies", ECM, "\n") 46 | 47 | ii <- findSignChanges(fn=detEqCMT2scan, par=par, makeplot=TRUE, W=WCM, no=no, threshold=1) 48 | zerosCMT2 <- findZeros(fn=detEqCMT2, q=WCM$q, ii=ii, L=L, Mpi=Mpi, par=par, makeplot=TRUE) 49 | ECM <- Eofqsq(zerosCME, dvec=c(0,0,0), Mpi=Mpi,L=L) 50 | cat("CM T2", zerosCMT2, "\n") 51 | 52 | 53 | ii <- findSignChanges(fn=detEqMF1A1scan, par=par, makeplot=TRUE, W=WMF1, no=no, threshold=1) 54 | zerosMF1 <- findZeros(fn=detEqMF1A1, q=WMF1$q, ii=ii, L=L, Mpi=Mpi, par=par, makeplot=TRUE) 55 | EMF1 <- Eofqsq(zerosMF1, dvec=c(0,0,1), Mpi=Mpi,L=L) 56 | cat("MF1", zerosMF1, "\n") 57 | 58 | ii <- findSignChanges(fn=detEqMF2A1scan, par=par, makeplot=TRUE, W=WMF2, no=no, threshold=.01) 59 | zerosMF2 <- findZeros(fn=detEqMF2A1, q=WMF2$q, ii=ii, L=L, Mpi=Mpi, par=par, makeplot=TRUE) 60 | EMF2 <- Eofqsq(zerosMF2, dvec=c(1,1,0), Mpi=Mpi, L=L) 61 | cat("MF2", zerosMF2, "\n") 62 | 63 | ii <- findSignChanges(fn=detEqMF3A1scan, par=par, makeplot=TRUE, W=WMF3, no=no, threshold=1) 64 | zerosMF3 <- findZeros(fn=detEqMF3A1, q=WMF3$q, ii=ii, L=L, Mpi=Mpi, par=par, makeplot=TRUE) 65 | EMF3 <- Eofqsq(zerosMF3, dvec=c(1,1,1), Mpi=Mpi, L=L) 66 | cat("MF3", zerosMF3, "\n") 67 | -------------------------------------------------------------------------------- /exec/scatteringlength/plot-mpia0.R: -------------------------------------------------------------------------------- 1 | require(tikzDevice) 2 | 3 | types <- c("-efm", "-ratio", "") 4 | odata <- read.table("scatteringlength.dat") 5 | 6 | for(j in c(1:length(types))) { 7 | load(paste("res", types[j], "-allens.Rdata", sep="")) 8 | 9 | x <- odata$V4/odata$V5 10 | 11 | tikz(paste("mpia0", types[j], ".tex", sep=""), standAlone = TRUE, width=5, height=5) 12 | 13 | ii <- c(1,2,5:7) 14 | plotwitherror(x=x[ii], y=res[ii,9], dy=res[ii,10], xlab=c("$M_{\\pi}/f_{\\pi}$"), ylab=c("$M_{\\pi}a_0$"), col=c("red"), pch=21, xlim=c(0,3), ylim=c(-0.35,0)) 15 | ii <- c(8,10,11) 16 | plotwitherror(x=x[ii], y=res[ii,9], dy=res[ii,10], xlab=c("$M_{\\pi}/f_{\\pi}$"), ylab=c("$M_{\\pi}a_0$"), col=c("blue"), pch=22, xlim=c(0,4), rep=TRUE) 17 | ii <- c(9) 18 | plotwitherror(x=x[ii], y=res[ii,9], dy=res[ii,10], xlab=c("$M_{\\pi}/f_{\\pi}$"), ylab=c("$M_{\\pi}a_0$"), col=c("darkgreen"), pch=23, xlim=c(0,4), rep=TRUE) 19 | 20 | legend(x="bottomleft", legend=c("A ensembles", "B ensembles", "D ensembles"), pt.bg=c("white", "white", "white"), col=c("red", "blue", "darkgreen"), pch=c(21:23)) 21 | dev.off() 22 | tools::texi2dvi(paste("mpia0", types[j], ".tex", sep=""), pdf=T) 23 | 24 | tikz(paste("mpia0-fs", types[j], ".tex", sep=""), standAlone = TRUE, width=5, height=5) 25 | 26 | x <- odata$V4/odata$V10/odata$V5*odata$V12 27 | L <- odata$V2 28 | a0 <- rep(0, times=length(res[,1])) 29 | jj <- c(1:length(res[,1])) 30 | for(i in jj) { 31 | a0[i] <- fs.a0(a0=res[i,5], L=L[i], mps=odata$V4[i]) 32 | } 33 | res[,9] <- res[,9]/odata$V10[jj]/res[,5]*a0 34 | ii <- c(1,2,5:7) 35 | plotwitherror(x=x[ii], y=res[ii,9], dy=res[ii,10], xlab=c("$M_{\\pi}/f_{\\pi}$"), ylab=c("$M_{\\pi}a_0$"), col=c("red"), pch=21, xlim=c(0,3), ylim=c(-0.35,0)) 36 | ii <- c(8,10,11) 37 | plotwitherror(x=x[ii], y=res[ii,9], dy=res[ii,10], xlab=c("$M_{\\pi}/f_{\\pi}$"), ylab=c("$M_{\\pi}a_0$"), col=c("blue"), pch=22, xlim=c(0,4), rep=TRUE) 38 | ii <- c(9) 39 | plotwitherror(x=x[ii], y=res[ii,9], dy=res[ii,10], xlab=c("$M_{\\pi}/f_{\\pi}$"), ylab=c("$M_{\\pi}a_0$"), col=c("darkgreen"), pch=23, xlim=c(0,4), rep=TRUE) 40 | 41 | legend(x="bottomleft", legend=c("A ensembles", "B ensembles", "D ensembles"), pt.bg=c("white", "white", "white"), col=c("red", "blue", "darkgreen"), pch=c(21:23)) 42 | ##dev.copy2pdf(file="qcotdelta.pdf") 43 | dev.off() 44 | tools::texi2dvi(paste("mpia0-fs", types[j], ".tex", sep=""), pdf=T) 45 | } 46 | 47 | ## produce empty plot with correct limits 48 | ## plot(x,y, type="n") 49 | ## add shaded band 50 | ## x <- c(1:10) 51 | ## polygon(x=c(x, rex(x)), y=c(x^2+1, rev(x^2)-1), col="gray", lty=0, lwd=0.001, border="red") 52 | ## plot points on top of it 53 | ## points(x,y) 54 | -------------------------------------------------------------------------------- /exec/rho-phaseshift/plot-Mrho.R: -------------------------------------------------------------------------------- 1 | ens <- c("A40.32", "A30.32", "A60.24", "A80.24", "B55.32") 2 | 3 | pch <- c(21, 22, 23, 24, 25) 4 | col <- c("red", "darkblue", "darkgreen", "purple", "orange", "black") 5 | 6 | r0data <- read.table("r0.dat") 7 | 8 | tikzfiles <- tikz.init(basename=paste("MrhoMpisq", sep=""), width=5., height=4.) 9 | 10 | plot(NA, xlim=c(0,1.2), ylim=c(1,2.5), xlab=c("$(r_0M_\\pi)^2$"), ylab=c("$r_0 M_\\rho$")) 11 | 12 | for(i in c(1:length(ens))) { 13 | cat(paste(ens[i], "/pion.Rdata", sep=""), "\n") 14 | load(paste(ens[i], "/pion.Rdata", sep="")) 15 | cat(paste(ens[i], "/Mrho-res", ens[i], ".Rdata", sep=""), "\n") 16 | load(paste(ens[i], "/Mrho-res", ens[i], ".Rdata", sep="")) 17 | 18 | k <- 1 19 | if(grepl("B", ens[i])) k <- 2 20 | if(grepl("D", ens[i])) k <- 3 21 | 22 | r0 <- r0data$V1[k] 23 | dr0 <- r0data$V2[k] 24 | boot.R <- 5000 25 | r0.boot <- rnorm(n=boot.R, mean=r0, sd=dr0) 26 | 27 | cat(r0*Mrho.res[1,2], "\n") 28 | cat((r0*pion.matrixfit$opt.res$par[1])^2, "\n") 29 | plotwitherror(x = (r0*pion.matrixfit$opt.res$par[1])^2, 30 | dx = sd((r0.boot*pion.matrixfit$opt.tsboot[1,])^2), 31 | y = r0*Mrho.res[1,2], 32 | dy = sd(r0.boot*Mrho.res[c(2:(boot.R+1)),2]), 33 | rep=TRUE, col=col[k], pch=pch[k], bg=col[k]) 34 | } 35 | 36 | legend("bottomright", legend=c("A ensembles", "B ensemble"), pch=pch[c(1:2)], col=col[c(1:2)], pt.bg=col[c(1:2)], bty="n") 37 | 38 | tikz.finalize(tikzfiles=tikzfiles) 39 | 40 | 41 | tikzfiles <- tikz.init(basename=paste("gMpisq", sep=""), width=5., height=4.) 42 | 43 | plot(NA, xlim=c(0,1.2), ylim=c(4,8), xlab=c("$(r_0M_\\pi)^2$"), ylab=c("$r_0 M_\\rho$")) 44 | 45 | for(i in c(1:length(ens))) { 46 | cat(paste(ens[i], "/pion.Rdata", sep=""), "\n") 47 | load(paste(ens[i], "/pion.Rdata", sep="")) 48 | cat(paste(ens[i], "/Mrho-res", ens[i], ".Rdata", sep=""), "\n") 49 | load(paste(ens[i], "/Mrho-res", ens[i], ".Rdata", sep="")) 50 | 51 | k <- 1 52 | if(grepl("B", ens[i])) k <- 2 53 | if(grepl("D", ens[i])) k <- 3 54 | 55 | r0 <- r0data$V1[k] 56 | dr0 <- r0data$V2[k] 57 | boot.R <- 5000 58 | r0.boot <- rnorm(n=boot.R, mean=r0, sd=dr0) 59 | 60 | cat(Mrho.res[1,1], "\n") 61 | cat((r0*pion.matrixfit$opt.res$par[1])^2, "\n") 62 | plotwitherror(x = (r0*pion.matrixfit$opt.res$par[1])^2, 63 | dx = sd((r0.boot*pion.matrixfit$opt.tsboot[1,])^2), 64 | y = Mrho.res[1,1], 65 | dy = sd(Mrho.res[c(2:(boot.R+1)),1]), 66 | rep=TRUE, col=col[k], pch=pch[k], bg=col[k]) 67 | } 68 | 69 | legend("bottomright", legend=c("A ensembles", "B ensemble"), pch=pch[c(1:2)], col=col[c(1:2)], pt.bg=col[c(1:2)], bty="n") 70 | tikz.finalize(tikzfiles=tikzfiles) 71 | -------------------------------------------------------------------------------- /exec/rho-phaseshift/summarise.R: -------------------------------------------------------------------------------- 1 | compute.weights <- function(err, pvalues) { 2 | return(pvalues^2 * min(err, na.rm=TRUE)^2/err^2) 3 | } 4 | 5 | compute.boots <- function(res, index=1) { 6 | pvalues <- as.vector((1-2*abs(res[1,,4]-0.5))) 7 | err <- apply(res[,,index], 2, sd, na.rm=TRUE) 8 | w <- compute.weights(err, pvalues) 9 | return(apply(res[,,index], 1, weighted.quantile, prob=c(0.5), w=w, na.rm=TRUE)) 10 | } 11 | 12 | 13 | summarise.rho <- function(ens, frame, irrep, PC, hint="no") { 14 | filelist <- Sys.glob(paste("./", "rhoana.", PC, ".*", ens, ".", frame, ".", irrep, ".Rdata", sep="")) 15 | 16 | N <- length(filelist) 17 | cat("processing", N, "data files for ensemble", ens, "and", PC, "\n") 18 | load(filelist[1]) 19 | R <- pc.matrixfit$boot.R 20 | rr <- c(2:(R+1)) 21 | 22 | res <- array(0, dim=c(R+1, N, 4)) 23 | 24 | for(i in c(1:N)) { 25 | load(filelist[i]) 26 | 27 | ## ECM 28 | res[1,i,1] <- gs$Ecm 29 | res[rr,i,1] <- gs$Ecmboot 30 | 31 | ##delta 32 | res[1,i,2] <- gs$delta 33 | res[rr,i,2] <- gs$deltaboot 34 | 35 | if(hint == "pi") { 36 | ii <- which(res[,i,2] < pi/2.) 37 | res[ii,i,2] <- res[ii,i,2] + pi 38 | } 39 | if(hint == "zero") { 40 | ii <- which(res[,i,2] > pi/2.) 41 | res[ii,i,2] <- res[ii,i,2] - pi 42 | } 43 | 44 | ##tan(delta) 45 | res[1,i,3] <- gs$tandelta 46 | res[rr,i,3] <- gs$tandeltaboot 47 | 48 | ## Qvals 49 | res[1,i,4] <- pc.matrixfit$Qval 50 | res[2,i,4] <- pion.matrixfit$Qval 51 | } 52 | 53 | save(res, file=paste("res", ens, frame, irrep, "Rdata", sep=".")) 54 | return(invisible(res)) 55 | } 56 | 57 | estimate.error <- function(res, index=1, prob=c(0.1573, 0.8427), main) { 58 | pvalues <- as.vector((1-2*abs(res[1,,4]-0.5))) 59 | 60 | err <- apply(res[,,index], 2, sd, na.rm=TRUE) 61 | w <- compute.weights(err, pvalues) 62 | x <- weighted.quantile(as.vector(res[1,,index]), prob=c(0.5), w=w, na.rm=TRUE) 63 | 64 | if(interactive()) X11() 65 | weighted.hist(x=as.vector(res[1,,index]), w=w, main=main, na.rm=TRUE) 66 | ## statistical 67 | x[2] <- sd(apply(res[,,index], 1, weighted.quantile, prob=c(0.5), w=w, na.rm=TRUE), na.rm=TRUE) 68 | ## systematic error 69 | ## lower and upper 70 | x[c(3:4)] <- weighted.quantile(as.vector(res[1,,index]), w=w, prob=prob, na.rm=TRUE)-x[1] 71 | return(x) 72 | } 73 | 74 | compute.error.rho <- function(res, prob=c(0.1573, 0.8427), PC) { 75 | Ecm <- estimate.error(res, index=1, prob=prob, main="Ecm") 76 | delta <- estimate.error(res, index=2, prob=prob, main="delta") 77 | tandelta <- estimate.error(res, index=3, prob=prob, main="tandelta") 78 | 79 | return(list(Ecm=Ecm, delta=delta, tandelta=tandelta, PC=PC)) 80 | } 81 | 82 | shift.delta <- function(res, threshold=-0.1, shift=pi) { 83 | ii <- which(res[,,2] < threshold) 84 | res[ii] <- res[ii] + shift 85 | return(res) 86 | } 87 | -------------------------------------------------------------------------------- /R/fit.plateau2cf.R: -------------------------------------------------------------------------------- 1 | #' fits a plateau to an object of class \code{cf} 2 | #' 3 | #' where applicable, a plateau is fitted to the averaged data in \code{cf} 4 | #' using a (correlated) chisquare fit. 5 | #' 6 | #' 7 | #' @param cf input object of class \code{cf} 8 | #' @param t1 starting t-value for the fit 9 | #' @param t2 final t-value for the fit. 10 | #' @param useCov perform a correlated chisquare fit or not. 11 | #' @return Returns a list with elements \item{plateau}{ the fitted plateau 12 | #' value } \item{dplateau}{ its error } 13 | #' @author Carsten Urbach \email{curbach@@gmx.de} 14 | #' @seealso \code{\link{cf}} 15 | #' @keywords bootstrap fit 16 | #' @examples 17 | #' 18 | #' data(correlatormatrix) 19 | #' cfnew <- extractSingleCor.cf(correlatormatrix, id=1) 20 | #' cfnew <- bootstrap.cf(cfnew, boot.R=99, boot.l=1) 21 | #' X <- fit.plateau2cf(cfnew, t1=13, t2=20) 22 | #' @export fit.plateau2cf 23 | fit.plateau2cf <- function(cf, t1, t2, useCov=FALSE) { 24 | stopifnot(inherits(cf, 'cf_meta')) 25 | stopifnot(inherits(cf, 'cf_boot')) 26 | 27 | boot.R <- cf$boot.R 28 | boot.l <- cf$boot.l 29 | ## fit interval 30 | ii <- c((t1+1):(t2+1)) 31 | ## error weights 32 | w <- 1/apply(cf$cf.tsboot$t[,ii], 2, sd) 33 | 34 | ## here we generate the inverse covariance matrix, if required 35 | ## otherwise take inverse errors squared 36 | M <- diag(w^2) 37 | 38 | if(useCov) { 39 | ## compute correlation matrix and compute the correctly normalised inverse 40 | M <- invertCovMatrix(cf$cf.tsboot$t[,ii], boot.samples = TRUE) 41 | } 42 | fn <- function(par, y, M) { sum((y-par[1]) %*% M %*% (y-par[1]))} 43 | 44 | par <- cf$cf0[cf$Time/4] 45 | opt.res <- optim(par, fn = fn, lower=cf$cf0[cf$Time/4]-4*cf$tsboot.se[cf$Time/4], upper=cf$cf0[cf$Time/4]+4*cf$tsboot.se[cf$Time/4], 46 | method="Brent", M=M, y = cf$cf0[ii]) 47 | opt.res <- optim(opt.res$par, fn = fn, lower=cf$cf0[cf$Time/4]-4*cf$tsboot.se[cf$Time/4], upper=cf$cf0[cf$Time/4]+4*cf$tsboot.se[cf$Time/4], 48 | control=list(parscale=1/opt.res$par), 49 | method="Brent", M=M, y = cf$cf0[ii]) 50 | par <- opt.res$par 51 | plateau <- par[1] 52 | chisqr <- opt.res$value 53 | dof <- length(ii)-1 54 | plateau.tsboot <- array(NA, dim=c(boot.R,2)) 55 | for(i in 1:boot.R) { 56 | opt <- optim(par, fn = fn, lower=cf$cf0[cf$Time/4]-4*cf$tsboot.se[cf$Time/4], upper=cf$cf0[cf$Time/4]+4*cf$tsboot.se[cf$Time/4], 57 | control=list(parscale=1/par), 58 | method="Brent", M=M, y = cf$cf.tsboot$t[i,ii]) 59 | plateau.tsboot[i,1] <- opt$par[1] 60 | plateau.tsboot[i,2] <- opt$value 61 | } 62 | 63 | dplateau <- sd(plateau.tsboot[,1]) 64 | res <- list(plateau=plateau, dplateau=dplateau, plateau.tsboot=plateau.tsboot, 65 | t0=plateau, se=dplateau, t=plateau.tsboot, 66 | chisqr=chisqr, dof=dof, 67 | cf=cf, t1=t1, t2=t2, boot.R=boot.R, boot.l=boot.l, useCov=useCov, 68 | invCovMatrix=M) 69 | return(invisible(res)) 70 | } 71 | -------------------------------------------------------------------------------- /tests/testthat/test_bootstrapfit.R: -------------------------------------------------------------------------------- 1 | context('bootstrap.nlsfit') 2 | 3 | model <- function (par, x, ...) { 4 | par[1] + x * par[2] 5 | } 6 | 7 | bsamples_x <- parametric.bootstrap(300, 1:10, rep(0.1, 10)) 8 | bsamples_y <- parametric.bootstrap(300, 1:10, rep(0.1, 10)) 9 | bsamples_yx <- cbind(bsamples_y, bsamples_x) 10 | cov_y <- cov(bsamples_y) 11 | cov_yx <- cov(bsamples_yx) 12 | x <- apply(bsamples_x, 2, mean) 13 | y <- apply(bsamples_y, 2, mean) 14 | mask <- 3:8 15 | 16 | psamples <- rnorm(300, 0.1, 0.1) 17 | 18 | test_that('y errors', { 19 | fit <- bootstrap.nlsfit( 20 | fn = model, 21 | par.guess = c(0, 1), 22 | x = x, 23 | y = y, 24 | bsamples = bsamples_y, 25 | mask = mask) 26 | skip_on_os(os="windows") 27 | expect_true(TRUE) 28 | }) 29 | 30 | test_that('y errors cov', { 31 | fit <- bootstrap.nlsfit( 32 | fn = model, 33 | par.guess = c(0, 1), 34 | x = x, 35 | y = y, 36 | bsamples = bsamples_y, 37 | CovMatrix = cov_y, 38 | mask = mask) 39 | skip_on_os(os="windows") 40 | expect_true(TRUE) 41 | }) 42 | 43 | test_that('xy errors', { 44 | fit <- bootstrap.nlsfit( 45 | fn = model, 46 | par.guess = c(0, 1), 47 | x = x, 48 | y = y, 49 | bsamples = bsamples_yx, 50 | mask = mask) 51 | skip_on_os(os="windows") 52 | expect_true(TRUE) 53 | }) 54 | 55 | test_that('xy errors cov', { 56 | fit <- bootstrap.nlsfit( 57 | fn = model, 58 | par.guess = c(0, 1), 59 | x = x, 60 | y = y, 61 | bsamples = bsamples_yx, 62 | CovMatrix = cov_yx, 63 | mask = mask) 64 | skip_on_os(os="windows") 65 | expect_true(TRUE) 66 | }) 67 | 68 | 69 | test_that('y errors with priors', { 70 | fit <- bootstrap.nlsfit( 71 | fn = model, 72 | par.guess = c(0, 1), 73 | x = x, 74 | y = y, 75 | bsamples = bsamples_y, 76 | priors = list(param = 1, p = 0.1, psamples = psamples), 77 | mask = mask) 78 | 79 | expect_true(TRUE) 80 | }) 81 | 82 | test_that('y errors cov with priors', { 83 | fit <- bootstrap.nlsfit( 84 | fn = model, 85 | par.guess = c(0, 1), 86 | x = x, 87 | y = y, 88 | bsamples = bsamples_y, 89 | CovMatrix = cov_y, 90 | priors = list(param = 1, p = 0.1, psamples = psamples), 91 | mask = mask) 92 | 93 | expect_true(TRUE) 94 | }) 95 | 96 | test_that('xy errors with priors', { 97 | fit <- bootstrap.nlsfit( 98 | fn = model, 99 | par.guess = c(0, 1), 100 | x = x, 101 | y = y, 102 | bsamples = bsamples_yx, 103 | priors = list(param = 1, p = 0.1, psamples = psamples), 104 | mask = mask) 105 | 106 | expect_true(TRUE) 107 | }) 108 | 109 | test_that('xy errors cov with priors', { 110 | fit <- bootstrap.nlsfit( 111 | fn = model, 112 | par.guess = c(0, 1), 113 | x = x, 114 | y = y, 115 | bsamples = bsamples_yx, 116 | CovMatrix = cov_yx, 117 | priors = list(param = 1, p = 0.1, psamples = psamples), 118 | mask = mask) 119 | skip_on_os(os="windows") 120 | expect_true(TRUE) 121 | }) 122 | -------------------------------------------------------------------------------- /R/boot_ts_array.R: -------------------------------------------------------------------------------- 1 | #' boot_ts_array 2 | #' 3 | #' @description 4 | #' Copy of boot:::ts.array 5 | #' 6 | #' The function `ts.array` of the `boot` package is not exported, yet we depend 7 | #' on it. It is bad to depend on private functions of a library, so we copy it 8 | #' here in the current version such that the `boot` package is free to change 9 | #' it. 10 | #' 11 | #' @param n integer. Length of original data 12 | #' @param n.sim The length of the simulated time series. Typically this will 13 | #' be equal to the length of the original time series but there 14 | #' are situations when it will be larger. One obvious situation 15 | #' is if prediction is required. Another situation in which 16 | #' ‘n.sim’ is larger than the original length is if ‘tseries’ is 17 | #' a residual time series from fitting some model to the 18 | #' original time series. In this case, ‘n.sim’ would usually be 19 | #' the length of the original time series. 20 | #' @param R A positive integer giving the number of bootstrap replicates 21 | #' required. 22 | #' @param l If ‘sim’ is ‘"fixed"’ then ‘l’ is the fixed block length used 23 | #' in generating the replicate time series. If ‘sim’ is 24 | #' ‘"geom"’ then ‘l’ is the mean of the geometric distribution 25 | #' used to generate the block lengths. ‘l’ should be a positive 26 | #' integer less than the length of ‘tseries’. This argument is 27 | #' not required when ‘sim’ is ‘"model"’ but it is required for 28 | #' all other simulation types. 29 | #' @param sim The type of simulation required to generate the replicate 30 | #' time series. The possible input values are ‘"model"’ (model 31 | #' based resampling), ‘"fixed"’ (block resampling with fixed 32 | #' block lengths of ‘l’), ‘"geom"’ (block resampling with block 33 | #' lengths having a geometric distribution with mean ‘l’) or 34 | #' ‘"scramble"’ (phase scrambling). 35 | #' @param endcorr boolean. whether or not to apply end correction 36 | #' 37 | #' @author Angelo Canty and Brian Ripley 38 | #' @keywords internal 39 | #' @return 40 | #' Returns a list with named elements `starts` and `lengths`. 41 | #' @export 42 | boot_ts_array <- function (n, n.sim, R, l, sim, endcorr) 43 | { 44 | endpt <- if (endcorr) 45 | n 46 | else n - l + 1 47 | cont <- TRUE 48 | if (sim == "geom") { 49 | len.tot <- rep(0, R) 50 | lens <- NULL 51 | while (cont) { 52 | temp <- 1 + rgeom(R, 1/l) 53 | temp <- pmin(temp, n.sim - len.tot) 54 | lens <- cbind(lens, temp) 55 | len.tot <- len.tot + temp 56 | cont <- any(len.tot < n.sim) 57 | } 58 | dimnames(lens) <- NULL 59 | nn <- ncol(lens) 60 | st <- matrix(sample.int(endpt, nn * R, replace = TRUE), 61 | R) 62 | } 63 | else { 64 | nn <- ceiling(n.sim/l) 65 | lens <- c(rep(l, nn - 1), 1 + (n.sim - 1)%%l) 66 | st <- matrix(sample.int(endpt, nn * R, replace = TRUE), 67 | R) 68 | } 69 | list(starts = st, lengths = lens) 70 | } 71 | -------------------------------------------------------------------------------- /R/legacy_functions.R: -------------------------------------------------------------------------------- 1 | ## The functions in this file date back to the very beginnings of hadron 2 | ## and are still used in a number of legacy routines, so they are kept 3 | ## around 4 | 5 | 6 | #' effmass 7 | #' 8 | #' computes the effective mass via the inverse cosh 9 | #' 10 | #' @param data numeric vector. data vector of length 4 11 | #' @param timeextent integer. time extent of the lattice 12 | #' @param t integer. physical time at which to evaluate the cosh 13 | #' 14 | #' @return 15 | #' Returns the effective mass as a single numeric value. 16 | #' 17 | effmass <- function(data, timeextent, t) { 18 | mass <- invcosh((data[1]+data[4])/(data[2]+data[3]), timeextent=timeextent, t=t) 19 | return(invisible(mass)) 20 | } 21 | 22 | #' effmass2 23 | #' 24 | #' computes the effective mass via the inverse cosh 25 | #' 26 | #' @param data numeric vector. data vector of length 4 27 | #' @param timeextent integer. time extent of the lattice 28 | #' @param t integer. physical time at which to evaluate the cosh 29 | #' 30 | #' @return 31 | #' Returns the effective mass as a single numeric value. 32 | effmass2 <- function(data, timeextent, t) { 33 | mass <- invcosh(ratio=(data[1])/(data[2]), timeextent=timeextent, t=t) 34 | return(invisible(mass)) 35 | } 36 | 37 | #' effectivemass 38 | #' 39 | #' computes the effective mass with error analysis using UWerr 40 | #' 41 | #' @param from integer. Fit in fitrange (from, to) 42 | #' @param to integer. see from. 43 | #' @param Time integer. time extent of the lattice 44 | #' @param Z data 45 | #' @param pl boolean. plot 46 | #' @param S numeric. see \link{uwerr} 47 | #' @param ... additional parameters passed to \link{uwerr} 48 | #' 49 | #' @seealso \link{uwerr} 50 | #' @return 51 | #' Returns a \link{data.frame} with named columns `t`, `mass`, `dmass`, 52 | #' `ddmass`, `tauint` and `dtauint`. 53 | effectivemass <- function(from, to, Time, Z, pl=TRUE, S,...) { 54 | L <- (to-from+1) 55 | i <- 1 56 | result <- data.frame(t = array(0.,dim=c(L)), mass = array(0.,dim=c(L)), dmass = array(0.,dim=c(L)), 57 | ddmass = array(0.,dim=c(L)), tauint = array(0.,dim=c(L)), dtauint = array(0.,dim=c(L))) 58 | for(t in from:to) { 59 | try(mass <- uwerrderived(f=effmass2, data=t(Z[t:(t+1),]), S=S, pl=F, timeextent=Time, t=t, ...)) 60 | 61 | result$t[i] <- t-1 62 | # these are NA, rather than single element vectors containing NA, so we need 63 | # to check for their lengths, otherwise the assignments below fail 64 | if( length(mass$value) > 0 ){ 65 | result$mass[i] <- mass$value[1] 66 | } 67 | if( length(mass$dvalue) > 0 ){ 68 | result$dmass[i] <- mass$dvalue[1] 69 | } 70 | if( length(mass$ddvalue) > 0 ){ 71 | result$ddmass[i] <- mass$ddvalue[1] 72 | } 73 | if( length(mass$tauint) > 0 ){ 74 | result$tauint[i] <- mass$tauint[1] 75 | } 76 | if( length(mass$dtauint) > 0 ){ 77 | result$dtauint[i] <- mass$dtauint[1] 78 | } 79 | i = i+1 80 | } 81 | rm(mass) 82 | rm(Z) 83 | attr(result, "class") <- c("massfit", "data.frame") 84 | if(pl == T) { 85 | new_window_if_appropriate() 86 | plot(result) 87 | } 88 | return(invisible(result)) 89 | } 90 | 91 | -------------------------------------------------------------------------------- /.clang-format: -------------------------------------------------------------------------------- 1 | --- 2 | Language: Cpp 3 | # BasedOnStyle: Google 4 | AccessModifierOffset: -1 5 | AlignAfterOpenBracket: Align 6 | AlignConsecutiveAssignments: false 7 | AlignConsecutiveDeclarations: false 8 | AlignEscapedNewlinesLeft: true 9 | AlignOperands: true 10 | AlignTrailingComments: true 11 | AllowAllParametersOfDeclarationOnNextLine: true 12 | AllowShortBlocksOnASingleLine: false 13 | AllowShortCaseLabelsOnASingleLine: false 14 | AllowShortFunctionsOnASingleLine: Inline 15 | AllowShortIfStatementsOnASingleLine: false 16 | AllowShortLoopsOnASingleLine: false 17 | AlwaysBreakAfterDefinitionReturnType: None 18 | AlwaysBreakAfterReturnType: None 19 | AlwaysBreakBeforeMultilineStrings: true 20 | AlwaysBreakTemplateDeclarations: true 21 | BinPackArguments: false 22 | BinPackParameters: false 23 | BraceWrapping: 24 | AfterClass: false 25 | AfterControlStatement: false 26 | AfterEnum: false 27 | AfterFunction: false 28 | AfterNamespace: false 29 | AfterObjCDeclaration: false 30 | AfterStruct: false 31 | AfterUnion: false 32 | BeforeCatch: false 33 | BeforeElse: false 34 | IndentBraces: false 35 | BreakBeforeBinaryOperators: None 36 | BreakBeforeBraces: Attach 37 | BreakBeforeTernaryOperators: true 38 | BreakConstructorInitializersBeforeComma: false 39 | BreakAfterJavaFieldAnnotations: false 40 | BreakStringLiterals: true 41 | ColumnLimit: 90 42 | CommentPragmas: '^ IWYU pragma:' 43 | ConstructorInitializerAllOnOneLineOrOnePerLine: true 44 | ConstructorInitializerIndentWidth: 4 45 | ContinuationIndentWidth: 4 46 | Cpp11BracedListStyle: true 47 | DerivePointerAlignment: false 48 | DisableFormat: false 49 | ExperimentalAutoDetectBinPacking: false 50 | ForEachMacros: [ foreach, Q_FOREACH, BOOST_FOREACH ] 51 | IncludeCategories: 52 | - Regex: '^<.*\.h>' 53 | Priority: 1 54 | - Regex: '^<.*' 55 | Priority: 2 56 | - Regex: '.*' 57 | Priority: 3 58 | IncludeIsMainRegex: '([-_](test|unittest))?$' 59 | IndentCaseLabels: true 60 | IndentWidth: 2 61 | IndentWrappedFunctionNames: false 62 | JavaScriptQuotes: Leave 63 | JavaScriptWrapImports: true 64 | KeepEmptyLinesAtTheStartOfBlocks: false 65 | MacroBlockBegin: '' 66 | MacroBlockEnd: '' 67 | MaxEmptyLinesToKeep: 1 68 | NamespaceIndentation: None 69 | ObjCBlockIndentWidth: 2 70 | ObjCSpaceAfterProperty: false 71 | ObjCSpaceBeforeProtocolList: false 72 | PenaltyBreakBeforeFirstCallParameter: 1 73 | PenaltyBreakComment: 300 74 | PenaltyBreakFirstLessLess: 120 75 | PenaltyBreakString: 1000 76 | PenaltyExcessCharacter: 1000000 77 | PenaltyReturnTypeOnItsOwnLine: 200 78 | PointerAlignment: Right 79 | ReflowComments: true 80 | SortIncludes: true 81 | SpaceAfterCStyleCast: false 82 | SpaceAfterTemplateKeyword: true 83 | SpaceBeforeAssignmentOperators: true 84 | SpaceBeforeParens: ControlStatements 85 | SpaceInEmptyParentheses: false 86 | SpacesBeforeTrailingComments: 2 87 | SpacesInAngles: false 88 | SpacesInContainerLiterals: true 89 | SpacesInCStyleCastParentheses: false 90 | SpacesInParentheses: false 91 | SpacesInSquareBrackets: false 92 | Standard: C++11 93 | TabWidth: 8 94 | UseTab: Never 95 | ... 96 | 97 | -------------------------------------------------------------------------------- /exec/phaseshift/singlepi.R: -------------------------------------------------------------------------------- 1 | singlepi <- function(t1, t2, T, redofit=TRUE, t.threshold=5, p="p0", path="./", srcpath="./", useCov=TRUE, verbose=TRUE, ending=".dat", boot.R=400, boot.l=1, ens, ind.vector=c(2,3)) { 2 | 3 | ## read pion data from file 4 | if(!file.exists(paste(path,"pidata.", p, ".Rdata", sep=""))) { 5 | pidata <- bootstrap.cf(readtextcf(paste("pi_corr_", p, ending, sep=""), T=T, check.t=1, path=srcpath, ind.vector=ind.vector), boot.R=boot.R, boot.l=boot.l, seed=seed) 6 | save(pidata, file=paste(path,"pidata.", p, ".Rdata", sep="")) 7 | } 8 | load(file=paste(path, "pidata.", p, ".Rdata", sep="")) 9 | 10 | if(redofit) { 11 | cat("...determining pion mass from effective mass and matrix fit\n") 12 | t1 <- t1 13 | t2 <- t2 14 | for(ta in c(t1:t2)) { 15 | if(t2-ta < t.threshold) break 16 | pion.effectivemass <- fit.effectivemass(bootstrap.effectivemass(cf=pidata, type="solve"), t1=ta, t2=t2-1, useCov=useCov) 17 | if(verbose) { 18 | summary(pion.effectivemass) 19 | plot(pion.effectivemass, xlab=c("t/a"), ylab=c("Meff"), main=paste("pion.", p, ".effectivemass.", ta, ".", t2, "p=", pion.effectivemass$Qval, sep="")) 20 | } 21 | ## save all of them 22 | meta.data <- list(ens=ens, T=T, srcpath=srcpath, t1=ta, t2=t2) 23 | save(meta.data, pion.effectivemass, file=paste(path, "pion.", p, ".effectivemass.", ta, ".", t2, ".Rdata", sep="")) 24 | pion.matrixfit <- matrixfit(pidata, t1=ta, t2=t2, useCov=useCov) 25 | save(pion.matrixfit, file=paste(path, "pion.", p, ".matrixfit.", ta, ".", t2, ".Rdata", sep="")) 26 | } 27 | } 28 | } 29 | 30 | pion.sys <- function(p = "p0", rep.outliers=FALSE) { 31 | 32 | compute.weights <- function(pvalues, err) { 33 | return(pvalues^2*min(err)^2/err^2) 34 | } 35 | 36 | filelist <- Sys.glob(paste("pion.", p, ".effectivemass.*.Rdata", sep="")) 37 | load(filelist[1]) 38 | boot.R <- pion.effectivemass$boot.R 39 | 40 | res <- array(0., dim=c(boot.R+1, length(filelist), 2)) 41 | for(i in c(1:length(filelist))) { 42 | load(filelist[i]) 43 | if(pion.effectivemass$boot.R != boot.R) { 44 | stop("inconsistent boot.R!\n") 45 | } 46 | res[1,i,1] <- pion.effectivemass$opt.res$par[1] 47 | res[c(2:(boot.R+1)), i, 1] <- pion.effectivemass$massfit.tsboot[,1] 48 | res[1,i,2] <- pion.effectivemass$Qval 49 | res[c(2:(boot.R+1)), i, 2] <- 1-pchisq(pion.effectivemass$massfit.tsboot[,2], pion.effectivemass$dof) 50 | } 51 | 52 | ## this is the naive statistical uncertainty 53 | err <- apply(res[,,1], 2, sd, na.rm=TRUE) 54 | ## weights 55 | pvalues <- 1-2*abs(res[1,,2]-0.5) 56 | ## weights 57 | w <- compute.weights(pvalues, err) 58 | ## value 59 | mpi <- weighted.quantile(res[1,,1], w=w, prob=c(0.5), na.rm=TRUE) 60 | ## statistical error 61 | dmpi <- sd(apply(res[,,1], 1, weighted.quantile, w=w, prob=c(0.5), na.rm=TRUE), na.rm=TRUE) 62 | ## systematic error 63 | ## lower 64 | smpim <- weighted.quantile(res[1,,1], w=w, prob=c(0.1573), na.rm=TRUE)-mpi 65 | ## upper 66 | smpip <- weighted.quantile(res[1,,1], w=w, prob=c(0.8427), na.rm=TRUE)-mpi 67 | 68 | return(invisible(list(res=res, mpi=data.frame(mpi=mpi, dmpi=dmpi, smpip=smpip, smpim=smpim)))) 69 | } 70 | -------------------------------------------------------------------------------- /vignettes/Two_Amplitudes_Model.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Two Amplitudes Model" 3 | author: "Martin Ueding" 4 | date: "31 3 2020" 5 | output: pdf_document 6 | vignette: > 7 | %\VignetteIndexEntry{Two Amplitudes Model} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | \usepackage[utf8]{inputenc} 10 | --- 11 | 12 | ```{r setup, include=FALSE} 13 | knitr::opts_chunk$set(echo = TRUE) 14 | library(hadron) 15 | ``` 16 | 17 | For fitting thermal pollutions one wants to try the following model: 18 | $$ 19 | A_1 \exp(E t) + A_2 \exp(E \cdot (T-t)) \,. 20 | $$ 21 | It has two amplitudes but only one energy. I have implemented this as `TwoAmplitudesModel` and restricted it to a single correlator. One could generalize this to fit a whole correlator matrix, but I cut the corners for now. 22 | 23 | What we actually implement is the following to be consistent with the `SingleModel`: 24 | $$ 25 | \frac12 \left( A_1^2 \exp(E t) + A_2^2 \exp(E \cdot (T-t)) \right) \,. 26 | $$ 27 | 28 | # Test with samplecf 29 | 30 | The samplecf correlation function does not have thermal pollutions. Therefore we expect the model to recover the same amplitude for forward and backward part. 31 | 32 | ```{r} 33 | scf <- bootstrap.cf(samplecf) 34 | plot(scf, log = 'y') 35 | ``` 36 | 37 | ```{r} 38 | fit_sample <- new_matrixfit(scf, 8, 22, model = 'single') 39 | plot(fit_sample, log = 'y') 40 | residual_plot(fit_sample, ylim = c(1/1.05, 1.05)) 41 | ``` 42 | 43 | ```{r} 44 | fit_sample_2 <- new_matrixfit(scf, 8, 22, model = 'two_amplitudes') 45 | plot(fit_sample_2, log = 'y') 46 | residual_plot(fit_sample_2, ylim = c(1/1.05, 1.05)) 47 | ``` 48 | 49 | Looking at the results from both fits, we see that the first fit produces $(E, A)$ which is reproduced by the second as $(E, A_1, A_2)$ pretty well: 50 | 51 | ```{r} 52 | mapply(tex.catwitherror, fit_sample$t0, fit_sample$se, with.dollar = FALSE) 53 | mapply(tex.catwitherror, fit_sample_2$t0, fit_sample_2$se, with.dollar = FALSE) 54 | ``` 55 | 56 | # Test with artificial data 57 | 58 | We can make up an example which has different forward and backward amplitudes and constant noise. 59 | 60 | ```{r} 61 | extent_time <- 48 62 | time <- seq(0, extent_time - 1, by = 1) 63 | model_E <- 0.015 64 | model_A1 <- 0.35 65 | model_A2 <- 0.4 66 | val <- 0.5 * model_A1^2 * exp(-model_E * time) + 0.5 * model_A2^2 * exp(-model_E * (extent_time - time)) 67 | ``` 68 | 69 | ```{r} 70 | plot(time, val, 71 | main = 'Model data', 72 | xlab = 't', 73 | ylab = 'C(t)') 74 | ``` 75 | 76 | ```{r} 77 | measurements <- do.call(cbind, lapply(val, function (v) rnorm(400, v, 0.01))) 78 | 79 | cf <- cf_orig(cf_meta(Time = extent_time), cf = measurements) 80 | cf <- symmetrise.cf(cf) 81 | cf_boot <- bootstrap.cf(cf) 82 | 83 | plot(cf_boot, log = 'y') 84 | ``` 85 | 86 | We fit that using the new model and 87 | 88 | ```{r} 89 | fit <- new_matrixfit(cf_boot, 2, 23, model = 'two_amplitudes') 90 | plot(fit, log = 'y') 91 | residual_plot(fit) 92 | ``` 93 | 94 | Comparing with the input from the model gives a reasonable result: 95 | 96 | ```{r} 97 | print(c(model_E, model_A1, model_A2)) 98 | mapply(tex.catwitherror, fit$t0, fit$se, with.dollar = FALSE) 99 | ``` 100 | 101 | -------------------------------------------------------------------------------- /exec/old/gsl_fit.R: -------------------------------------------------------------------------------- 1 | # ... 2 | 3 | gsl_fit_smeared_correlator <- function(par, Thalf, x, y, err, tr, prec=c(1.e-10,1.e-4), N=1) { 4 | if(missing(par)) { 5 | stop("Error, parameter list must be given!") 6 | } 7 | #etc 8 | 9 | npar <- length(par) 10 | parsave <- numeric(npar) 11 | parsave <- par 12 | 13 | state <- .Call("multifit_smearedcor", par, Thalf, x, y, err, tr, prec, N, 500, 1) 14 | if(state[5] >= 0) { 15 | return(invisible(list(par=state[6:(npar+5)], value=state[1], 16 | convergence=state[5], counts = state[3], dof = state[4]))) 17 | } 18 | else if(state[5] < 0) { 19 | ##state <- .Call("multimin_cor", parsave, Thalf, x, y, err, tr, prec, N, 500, no_masses) 20 | ##if(state[5] < 0) { 21 | warning("gsl_multifit did not converge ", state[5], " chisqr ", 22 | state[1], "\npars ", state[6:(npar+5)], 23 | "\nResults may be unreliable!\nPlease try to vary initial guesses!"); 24 | ##} 25 | } 26 | 27 | return(invisible(list(par=state[6:(npar+5)], value=state[1], 28 | convergence=state[5], counts = state[3], dof = state[4]))) 29 | } 30 | 31 | gsl_fit_correlator_matrix <- function(par, Thalf, x, y, err, tr, N, no_masses=1, prec=c(1.e-10,1.e-4)) { 32 | if(missing(par)) { 33 | stop("Error, parameter list must be given!") 34 | } 35 | #etc 36 | 37 | npar <- length(par) 38 | parsave <- numeric(npar) 39 | parsave <- par 40 | ## for(i in 1:npar) parsave[i] <- par[i] 41 | 42 | state <- .Call("multifit_cor", par, Thalf, x, y, err, tr, prec, N, 500, no_masses) 43 | if(state[5] >= 0) { 44 | return(invisible(list(par=state[6:(npar+5)], value=state[1], 45 | convergence=state[5], counts = state[3], dof = state[4]))) 46 | } 47 | else if(state[5] < 0) { 48 | state <- .Call("multimin_cor", parsave, Thalf, x, y, err, tr, prec, N, 500, no_masses) 49 | if(state[5] < 0) { 50 | warning("gsl_multifit and multimin did not converge ", state[5], " chisqr ", 51 | state[1], "\npars ", state[6:(npar+5)], 52 | "\nResults may be unreliable!\nPlease try to vary initial guesses!"); 53 | } 54 | } 55 | 56 | return(invisible(list(par=state[6:(npar+5)], value=state[1], 57 | convergence=state[5], counts = state[3], dof = state[4]))) 58 | } 59 | 60 | gsl_min_correlator_matrix <- function(par, Thalf, x, y, err, tr, N, no_masses=1, prec=c(1.e-10,1.e-4)) { 61 | if(missing(par)) { 62 | stop("Error, parameter list must be given!") 63 | } 64 | #etc 65 | 66 | npar <- length(par) 67 | parsave <- numeric(npar) 68 | 69 | state <- .Call("multimin_cor", par, Thalf, x, y, err, tr, prec, N, 500, no_masses) 70 | if(state[5] < 0) { 71 | warning("gsl_multimin did not converge ", state[5], " chisqr ", state[1], "\npars ", state[6:(npar+5)]) 72 | state <- .Call("multifit_cor", parsave, Thalf, x, y, err, tr, prec, N, 500, no_masses) 73 | if(state[5] < 0) warning("failed again...") 74 | } 75 | 76 | return(invisible(list(par=state[6:(npar+5)], value=state[1], 77 | convergence=state[5], counts = state[3], dof = state[4]))) 78 | } 79 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: hadron 2 | Version: 3.4.1 3 | Date: 2025-10-09 4 | Title: Analysis Framework for Monte Carlo Simulation Data 5 | in Physics 6 | Authors@R: 7 | c(person(given = "Bartosz", 8 | family = "Kostrzewa", 9 | role = "aut", 10 | email = "bartosz.kostrzewa@desy.de"), 11 | person(given = "Johann", 12 | family = "Ostmeyer", 13 | role = "aut", 14 | email = "ostmeyer@hiskp.uni-bonn.de"), 15 | person(given = "Martin", 16 | family = "Ueding", 17 | role = "aut", 18 | email = "mu@martin-ueding.de"), 19 | person(given = "Carsten", 20 | family = "Urbach", 21 | role = c("aut", "cre"), 22 | email = "urbach@hiskp.uni-bonn.de"), 23 | person(given = "Nikolas", 24 | family = "Schlage", 25 | role = "ctb"), 26 | person(given = "Markus", 27 | family = "Werner", 28 | role = "ctb"), 29 | person(given = "Ferenc", 30 | family = "Pittler", 31 | role = "ctb"), 32 | person(given = "Matthias", 33 | family = "Fischer", 34 | role = "ctb"), 35 | person(given = "Vittorio", 36 | family = "Lubicz", 37 | role = "ctb")) 38 | SystemRequirements: Gnu Scientific Library version >= 1.8 39 | Description: Toolkit to perform statistical analyses of correlation 40 | functions generated from Lattice Monte Carlo simulations. In 41 | particular, a class 'cf' for correlation functions and 42 | methods to analyse those are defined. This includes (blocked) 43 | bootstrap (based on the 'boot' package) and jackknife, but also an 44 | automatic determination of integrated autocorrelation 45 | times. 'hadron' also provides a very general function 46 | bootstrap.nlsfit() to bootstrap a non-linear least squares fit. 47 | More specific functions are provided to extract hadronic quantities 48 | from Lattice Quantum Chromodynamics simulations, a particular Monte 49 | Carlo simulation,(see e.g. European Twisted Mass Collaboration, P. Boucaud et 50 | al. (2008) ). Here, to determine 51 | energy eigenvalues of hadronic states, specific fitting routines 52 | and in particular the generalised eigenvalue method (see 53 | e.g. B. Blossier et al. (2009) 54 | and M. Fischer et al. (2020) 55 | ) are implemented. 56 | In addition, input/output and plotting routines are available. 57 | Imports: 58 | abind, 59 | boot, 60 | dplyr, 61 | R6, 62 | Rcpp, 63 | stringr 64 | LinkingTo: 65 | Rcpp 66 | Suggests: 67 | minpack.lm, 68 | parallel, 69 | rhdf5, 70 | knitr, 71 | testthat, 72 | tictoc, 73 | tikzDevice, 74 | hash, 75 | numDeriv, 76 | staplr, 77 | markdown, 78 | rmarkdown, 79 | errors 80 | License: GPL-3 81 | URL: https://github.com/HISKP-LQCD/hadron 82 | BugReports: https://github.com/HISKP-LQCD/hadron/issues 83 | NeedsCompilation: yes 84 | LazyData: true 85 | Roxygen: list(markdown = TRUE, old_usage = TRUE, r6 = FALSE) 86 | RoxygenNote: 7.3.2 87 | Encoding: UTF-8 88 | VignetteBuilder: knitr 89 | -------------------------------------------------------------------------------- /exec/online_measurements_status_template.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "cB211.25.48 simulation status" 3 | author: Bartosz Kostrzewa 4 | date: "`r format(Sys.time(), '%d %B, %Y')`" 5 | header-includes: 6 | - \usepackage{braket} 7 | - \usepackage{pdfpages} 8 | output: 9 | pdf_document: 10 | citation_package: biblatex 11 | latex_engine: lualatex 12 | highlight: tango 13 | keep_tex: no 14 | toc: true 15 | toc_depth: 2 16 | bibliography: skeleton.bib 17 | link-citations: yes 18 | mainfont: XCharter 19 | tables: true 20 | --- 21 | 22 | ```{r eval=TRUE, echo=FALSE, message=FALSE, warning=FALSE} 23 | library("hadron") 24 | library("knitr") 25 | library("dplyr") 26 | library("pander") 27 | library("kableExtra") 28 | knitr::opts_chunk$set(fig.path="figures/", 29 | echo=FALSE, 30 | warning=FALSE, 31 | message=FALSE, 32 | dev="tikz", 33 | external=TRUE, 34 | fig.width=4.0, 35 | fig.height=3.6) 36 | styling_latex_hold_position <- function(x) { 37 | sub("\\\\begin\\{table\\}", "\\\\begin\\{table\\}[!h]", x) 38 | } 39 | ``` 40 | 41 | # Summary Tables 42 | 43 | ## cB211a.25.48 44 | 45 | ```{r} 46 | load("omeas.summary.RData") 47 | load("gradflow.summary.RData") 48 | styling_latex_hold_position( 49 | kable(list(t(resultsum[["cB211a.25.48"]]$params), 50 | t(resultsum[["cB211a.25.48"]]$obs)), 51 | format = "latex", 52 | booktabs = TRUE, 53 | caption = "cB211a.25.48 obervables summary") 54 | ) 55 | ``` 56 | 57 | ## cB211b.25.48 58 | 59 | ```{r} 60 | styling_latex_hold_position( 61 | kable(list(t(resultsum[["cB211b.25.48"]]$params), 62 | t(resultsum[["cB211b.25.48"]]$obs)), 63 | booktabs = TRUE, 64 | format = "latex", 65 | caption = "cB211b.25.48 observables summary") 66 | ) 67 | ``` 68 | 69 | \par 70 | \clearpage 71 | 72 | # Gradient Flow Summary Tables 73 | 74 | ```{r} 75 | styling_latex_hold_position( 76 | kable(gradflow_resultsum[["cB211a.25.48"]], 77 | format = "latex", 78 | booktabs = TRUE, 79 | caption = "cB211a.25.48 gradient flow observables summary") 80 | ) 81 | styling_latex_hold_position( 82 | kable(gradflow_resultsum[["cB211b.25.48"]], 83 | format = "latex", 84 | booktabs = TRUE, 85 | caption = "cB211b.25.48 gradient flow observables summary") 86 | ) 87 | ``` 88 | 89 | # Plots 90 | 91 | ```{r results="asis"} 92 | library(pdftools) 93 | pdfs <- c("analysis_cB211a.25.48.pdf", 94 | "cB211a.25.48.gradflow.pdf", 95 | "analysis_cB211b.25.48.pdf", 96 | "cB211b.25.48.gradflow.pdf") 97 | for( f in pdfs ){ 98 | cat(sprintf("\\subsection{%s}\n",escape_underscore(f))) 99 | npages <- pdf_info(f)$pages 100 | for( p in 1:npages ){ 101 | cat( 102 | sprintf("\\includegraphics[width=0.45\\textwidth, page=%d]{{{%s}}}\n", 103 | p, 104 | tools::file_path_sans_ext(f) 105 | ) 106 | ) 107 | # using a paragraph instead of a linebreak helps to avoid placing plots 108 | # such that they flow out of the page 109 | if( p%%2 == 0 ){ 110 | cat("\\par") 111 | } 112 | } 113 | #cat("\\end{figure}\n") 114 | } 115 | ``` 116 | 117 | 118 | -------------------------------------------------------------------------------- /exec/analyse.nd-kaon.8x8.R: -------------------------------------------------------------------------------- 1 | 2 | ## we analyse 8x8 matrix for the kaon 3 | ## we need to read four files corresponding to heavy propagators as 4 | file.strings <- c("ss", "sc", "cs", "cc") 5 | 6 | if(FALSE) { 7 | for(i in c(1:4)) { 8 | files <- getorderedfilelist(basename=paste("outprcv.l", file.strings[i], ".", sep="")) 9 | ## set skip to 1 for libcvcpp 10 | assign(file.strings[i], readcmidatafiles(files, skip=1, verbose=TRUE)) 11 | } 12 | } 13 | load("ss.Rdata") 14 | load("sc.Rdata") 15 | load("cs.Rdata") 16 | load("cc.Rdata") 17 | 18 | flavour.strings <- array(c("cc", "cs", "cc", "cs", 19 | "sc", "ss", "sc", "ss", 20 | "cc", "cs", "cc", "cs", 21 | "sc", "ss", "sc", "ss"), 22 | dim=c(4,4)) 23 | 24 | 25 | ## the following have to be chosen for the heavyheavy code 26 | flavour.factors <- 0.5*array(c(-1, 1, 1, 1, 27 | 1, -1, -1, -1, 28 | 1, -1, 1, 1, 29 | 1, -1, 1, 1), dim=c(4,4)) 30 | 31 | gamma.indices.hh <- array(c(4, 4, 3, 3, 32 | 4, 4, 3, 3, 33 | 2, 2, 1, 1, 34 | 2, 2, 1, 1), 35 | dim=c(4,4)) 36 | 37 | ## and this here for libcvcpp (might change in the future...) 38 | flavour.factors.cvc <- 0.5*array(c(-1, 1, -1, -1, 39 | 1, -1, 1, 1, 40 | -1, 1, 1, 1, 41 | -1, 1, 1, 1), dim=c(4,4)) 42 | 43 | gamma.indices <- array(c(5, 5, 7, 7, 44 | 5, 5, 7, 7, 45 | 6, 6, 1, 1, 46 | 6, 6, 1, 1), 47 | dim=c(4,4)) 48 | 49 | if(!file.exists("Cmatrix.Rdata")) { 50 | Cmatrix <- cf() 51 | 52 | for(i in c(1:4)) { 53 | for(j in c(1:4)) { 54 | tmp <- extract.obs(eval(as.name(flavour.strings[j,i])), vec.obs=c(gamma.indices[j,i])) 55 | Cmatrix <- c(Cmatrix, mul.cf(tmp, a=flavour.factors[j,i])) 56 | } 57 | } 58 | 59 | ## we bootstrap the matrix and save 60 | Cmatrix <- bootstrap.cf(Cmatrix, boot.R=400, boot.l=2) 61 | save(Cmatrix, file="Cmatrix.Rdata") 62 | } 63 | load("Cmatrix.Rdata") 64 | 65 | ## we use element.order to bring the matrix into the right order 66 | Cmatrix.bootstrap.gevp <- bootstrap.gevp(Cmatrix, matrix.size=8, 67 | element.order=c( 68 | 1, 2, 5, 6, 9,10,13,14, 69 | 3, 4, 7, 8, 11,12,15,16, 70 | 17,19,21,22, 25,26,29,30, 71 | 18,20,23,24, 27,28,31,32, 72 | 33,35,37,39, 41,42,45,46, 73 | 34,36,38,40, 43,44,47,48, 74 | 49,51,53,55, 57,59,61,62, 75 | 50,52,54,56, 58,60,63,64)) 76 | 77 | ## solve the GEVP 78 | kaon.pc1 <- gevp2cf(Cmatrix.bootstrap.gevp, id=1) 79 | kaon.pc1.effectivemass <- bootstrap.effectivemass(cf=kaon.pc1, type="solve") 80 | kaon.pc1.effectivemass <- fit.effectivemass(kaon.pc1.effectivemass, t1=10, t2=23, useCov=FALSE) 81 | plot(kaon.pc1.effectivemass, ylim=c(0.1,0.3)) 82 | summary(kaon.pc1.effectivemass) 83 | -------------------------------------------------------------------------------- /tests/testthat/test_tex_catwitherror.R: -------------------------------------------------------------------------------- 1 | context('tex_catwitherror') 2 | 3 | test_that('small_error', { 4 | expect_equal(tex.catwitherror(1.23, 0.45, digits = 2, with.dollar = FALSE), '1.23(45)') 5 | expect_equal(tex.catwitherror(1.23, 0.450001, digits = 1, with.dollar = FALSE), '1.2(5)') 6 | expect_equal(tex.catwitherror(1.23, 0.001, digits = 1, with.dollar = FALSE), '1.230(1)') 7 | expect_equal(tex.catwitherror(123, 1, digits = 1, with.dollar = FALSE), '123(1)') 8 | }) 9 | 10 | test_that('borderline_error', { 11 | expect_equal(tex.catwitherror(1.330563782105, 0.000966674080, digits = 1, with.dollar = FALSE), '1.331(1)') 12 | }) 13 | 14 | test_that('another_borderline_error', { 15 | expect_equal(tex.catwitherror(0.031921636680, 0.000098, digits = 1, with.dollar=FALSE), '0.0319(1)') 16 | }) 17 | 18 | test_that('even_nastier_borderline_error', { 19 | expect_equal(tex.catwitherror(1.330563782105, 0.996674080, digits = 2, with.dollar = FALSE), '1.3(10)') 20 | }) 21 | 22 | test_that('scientific_notation', { 23 | expect_equal(tex.catwitherror(0.0008970, 0.0002106, with.dollar = FALSE, with.cdot = TRUE, digits = 2), '9.0(21)\\cdot 10^{-4}') 24 | }) 25 | 26 | test_that('very_small_number', { 27 | expect_equal(tex.catwitherror(1.23e-20, 0.45e-20, digits = 2, with.dollar = FALSE, with.cdot = FALSE), '1.23(45)e-20') 28 | expect_equal(tex.catwitherror(1.23e-40, 0.45e-40, digits = 2), '$1.23(45)\\cdot 10^{-40}$') 29 | 30 | expect_equal(tex.catwitherror(1.23e-40, digits = 2, with.dollar = FALSE, with.cdot = FALSE), '1.2e-40') 31 | }) 32 | 33 | test_that('same_error', { 34 | expect_equal(tex.catwitherror(0.00123, 0.00123, digits = 4, with.dollar = FALSE), '0.001230(1230)') 35 | expect_equal(tex.catwitherror(12.346, 12.346, digits = 4, with.dollar = FALSE), '12.35(1235)') 36 | }) 37 | 38 | test_that('intermediate_error', { 39 | expect_equal(tex.catwitherror(175.2, 23.3, digits = 3, with.dollar = FALSE), '175.2(233)') 40 | }) 41 | 42 | test_that('large_error', { 43 | expect_equal(tex.catwitherror(0.00123, 0.45, digits = 4, with.dollar = FALSE), '0.0012(4500)') 44 | expect_equal(tex.catwitherror(1.12345, 12.3, digits = 4, with.dollar = FALSE), '1.12(1230)') 45 | }) 46 | 47 | test_that('similar_error', { 48 | expect_equal(tex.catwitherror(7492.8291130334482659, 1759.0859320695926726, 49 | digits = 3, with.dollar = FALSE), '7490(1760)') 50 | }) 51 | 52 | test_that('no_error', { 53 | expect_equal(tex.catwitherror(0.00123, digits = 4, with.dollar = FALSE, flag = "#"), '0.001230') 54 | }) 55 | 56 | test_that('zero_error', { 57 | expect_equal(tex.catwitherror(0.00000123, 0, digits = 4, with.dollar = FALSE, with.cdot = FALSE), '1.23(0)e-06') 58 | expect_equal(tex.catwitherror(0.00123, 0, digits = 4, with.dollar = FALSE), '0.00123(0)') 59 | expect_equal(tex.catwitherror(12.345, 0, digits = 3, with.dollar = FALSE), '12.3(0)') 60 | }) 61 | 62 | test_that('zero_val_zero_err', { 63 | expect_equal(tex.catwitherror(0., 0., digits = 4, with.dollar = FALSE, flag="#"), '0.000(0)') 64 | }) 65 | 66 | test_that('NA', { 67 | expect_equal(tex.catwitherror(NA, NA, digits = 4, with.dollar = FALSE), 'NA( NA)') 68 | }) 69 | 70 | test_that('vector', { 71 | for (i in 1:10) { 72 | x <- runif(1) 73 | dx <- runif(1) 74 | expect_equal(tex.catwitherror(x, dx, digits = 4), 75 | tex.catwitherror(c(x, dx), digits = 4)) 76 | } 77 | }) 78 | -------------------------------------------------------------------------------- /exec/analyse.eta_ss.R: -------------------------------------------------------------------------------- 1 | ## we analyse the connected only heavy-heavy contributions to 2 | ## the eta correlation matrix 3 | ## we need the following flavour combinations 4 | 5 | flavour.strings <- array(c("cscs","cssc","sccs","scsc", "cscc","csss","sccc","scss", 6 | "cccs","ccsc","sscs","sssc", "cccc","ccss","sscc","ssss"), 7 | dim=c(4,2,2)) 8 | 9 | elements.strings <- array(c("ss", "sp", "ps", "pp"), dim=c(2,2)) 10 | 11 | ## mapping needed to create the filenames of the input files 12 | ## mapping is needed because of gamma_5 trick etc. 13 | flavour.mapping <- function(s) { 14 | return(paste(substr(s,1,1), substr(s,4,4), substr(s,2,2), substr(s,3,3), sep="")) 15 | } 16 | 17 | flavour.factors <- array(c(+.25,-.25,-.25,+.25, +.25,+.25,-.25,-.25, 18 | -.25,+.25,-.25,+.25, +.25,+.25,+.25,+.25), 19 | dim=c(4,2,2)) 20 | ## the following have to be chosen for the heavyheavy code 21 | gamma.indices <- array(c(4,4,4,4, 3,3,3,3, 22 | 2,2,2,2, 1,1,1,1), 23 | dim=c(4,2,2)) 24 | ## and this here for libcvcpp (might change in the future...) 25 | ##gamma.indices <- array(c(5,5,5,5, 7,7,7,7, 26 | ## 6,6,6,6, 1,1,1,1), 27 | ## dim=c(4,2,2)) 28 | 29 | 30 | # set reread = TRUE when you want to read the data again 31 | reread <- FALSE 32 | if(!file.exists("Cmatrix.Rdata") || reread) { 33 | for(i in c(1:2)) { 34 | for(j in c(1:2)) { 35 | for(k in c(1:4)) { 36 | files <- getorderedfilelist(basename=paste("outprcvn.", flavour.mapping(flavour.strings[k,i,j]), ".", sep="")) 37 | ## set skip to 1 for libcvcpp 38 | cmicor <- readcmidatafiles(files, skip=0, verbose=TRUE) 39 | assign(flavour.strings[k,i,j], extract.obs(cmicor, vec.obs=c(gamma.indices[k,i,j]))) 40 | if(k == 1) { 41 | assign("tmp", eval(as.name(flavour.strings[k,i,j]))) 42 | tmp <- mul.cf(tmp, flavour.factors[k,i,j]) 43 | } 44 | else { 45 | tmp <- add.cf(tmp, eval(as.name(flavour.strings[k,i,j])), a=1., b=flavour.factors[k,i,j]) 46 | } 47 | } 48 | assign(elements.strings[i,j], tmp) 49 | rm(tmp) 50 | } 51 | } 52 | 53 | ## now we coerce to obtain the full matrix 54 | ## note that here we have smearing as fastest index 55 | Cmatrix <- c(eval(as.name(elements.strings[1,1])), eval(as.name(elements.strings[1,2])), 56 | eval(as.name(elements.strings[2,1])), eval(as.name(elements.strings[2,2]))) 57 | 58 | ## we bootstrap the matrix and save 59 | Cmatrix <- bootstrap.cf(Cmatrix, boot.R=400, boot.l=2) 60 | save(Cmatrix, file="Cmatrix.Rdata") 61 | } 62 | load("Cmatrix.Rdata") 63 | 64 | ## we use element.order to bring the matrix into the right order 65 | Cmatrix.bootstrap.gevp <- bootstrap.gevp(Cmatrix, matrix.size=4, 66 | element.order=c( 67 | 1,2,5,6, 68 | 3,4,7,8, 69 | 9,11,13,14, 70 | 10,12,15,16)) 71 | 72 | ## solve the GEVP 73 | etass.pc1 <- gevp2cf(Cmatrix.bootstrap.gevp, id=1) 74 | etass.pc1.effectivemass <- bootstrap.effectivemass(cf=etass.pc1, type="acosh") 75 | etass.pc1.effectivemass <- fit.effectivemass(etass.pc1.effectivemass, t1=12, t2=23, useCov=TRUE) 76 | plot(etass.pc1.effectivemass, ylim=c(0.2,0.4)) 77 | summary(etass.pc1.effectivemass) 78 | -------------------------------------------------------------------------------- /R/invertCovMatrix.R: -------------------------------------------------------------------------------- 1 | #' Inverts the covariance matrix for noisy data 2 | #' 3 | #' The covariance matrix of noisy data is inverted. Special care is taken in 4 | #' treating spurious small modes of the matrix, which are likely to arise from 5 | #' too much noise in the data. 6 | #' 7 | #' The inverse covariance matrix is estimated. If the number of observations is 8 | #' too small the procedure described in the reference is used to remove 9 | #' spuriously small eigenvalues of the covariance matrix. 10 | #' 11 | #' We always keep the \eqn{\sqrt{R}}{sqrt(R)} largest eigenvalues exactly and 12 | #' replace the remaining smallest ones by their mean. 13 | #' 14 | #' @param cf The data for which the covariance matrix is to be computed. It is 15 | #' expected to be an array or matrix with dimension RxN, where R is the number 16 | #' of observations and N the number of observables. 17 | #' 18 | #' \code{cf} can be either real data or bootstrap data. In the latter case 19 | #' \code{boot.samples=TRUE} must be set for proper normalisation of the inverse 20 | #' matrix. 21 | #' @param boot.l If set to a value larger than 1 the data will be blocked with 22 | #' blocklength \code{boot.l} before the covariance matrix is computed. 23 | #' @param boot.samples If set to \code{TRUE} the data is treated a pseudo data 24 | #' from a bootstrap procedure. 25 | #' @param cov_fn Function that computes the covariance matrix from the given 26 | #' samples. 27 | #' @return Returns the inverse covariance matrix as an object of class 28 | #' \code{\link{matrix}}. 29 | #' @author Carsten Urbach, \email{curbach@@gmx.de} 30 | #' @seealso \code{\link{cov}}, \code{\link{matrix}} 31 | #' @references C.Michael, A.McKerrell, Phys.Rev. D51 (1995) 3745-3750, 32 | #' hep-lat/9412087 33 | #' @keywords covariance matrix correlated chisqr 34 | #' @examples 35 | #' X <- array(rnorm(4000), dim=c(1000, 4)) 36 | #' invertCovMatrix(cf=X, boot.samples=TRUE) 37 | #' M <- invertCovMatrix(cf=X, boot.samples=TRUE) 38 | #' M 39 | #' 40 | #' @export invertCovMatrix 41 | invertCovMatrix <- function(cf, boot.l=1, boot.samples=FALSE, cov_fn = cov) { 42 | ## compute compute the correctly normalised inverse of a noisy covariance matrix 43 | ## see C. Michael hep-lat/9412087 44 | 45 | ## block data first, this should only be done if we're not dealing with boostrap samples 46 | ## because these already stem from an appropriate block sampling procedure 47 | ncf <- cf 48 | if(boot.l > 1 && boot.samples == FALSE) { 49 | ncf <- block.ts(cf, l=boot.l) 50 | } 51 | ## compute covariance matrix and invert 52 | CovMatrix <- cov_fn(ncf) 53 | ## we have a real, symmetric square matrix with dimension n=length(ncf[1,]) 54 | n <- length(ncf[1,]) 55 | ## the number of observations 56 | N <- length(ncf[,1]) 57 | M <- matrix() 58 | 59 | if(n > floor(sqrt(N))) { 60 | ## use singular value decomposition 61 | cov.svd <- svd(CovMatrix) 62 | ## replace smallest singular values by their mean, if needed 63 | ## we keep floor(sqrt(N)) exact eigenvalues and replace all smaller once 64 | ## by their average value 65 | cov.svd$d[floor(sqrt(N)):n] <- 66 | mean(cov.svd$d[floor(sqrt(N)):n]) 67 | ## construct the inverse 68 | D <- diag(1./cov.svd$d) 69 | M <- cov.svd$v %*% D %*% t(cov.svd$u) 70 | } 71 | else { 72 | ## use cholesky decomposition for real symmetric matrix 73 | M <- chol2inv(chol(CovMatrix)) 74 | } 75 | ## for bootstrap samples the error is equal to sd 76 | ## otherwise to sd/sqrt(N) 77 | if(!boot.samples) { 78 | M <- N*M 79 | } 80 | return(invisible(M)) 81 | } 82 | -------------------------------------------------------------------------------- /exec/old/nucleon.R: -------------------------------------------------------------------------------- 1 | One <- diag(1+0.*1i, 4, 4) 2 | 3 | Gamma4 <- matrix(c(0+0*1i, 0+0*1i, -1+0*1i, 0+0*1i, 4 | 0+0*1i, 0+0*1i, 0+0*1i, -1+0*1i, 5 | -1+0*1i, 0+0*1i, 0+0*1i, 0+0*1i, 6 | 0+0*1i, -1+0*1i, 0+0*1i, 0+0*1i), 7 | nrow=4, ncol=4) 8 | 9 | 10 | Gamma5 <- matrix(c(1+0*1i, 0+0*1i, 0+0*1i, 0+0*1i, 11 | 0+0*1i, 1+0*1i, 0+0*1i, 0+0*1i, 12 | 0+0*1i, 0+0*1i, -1+0*1i, 0+0*1i, 13 | 0+0*1i, 0+0*1i, 0+0*1i, -1+0*1i), 14 | nrow=4, ncol=4) 15 | 16 | #' proton 17 | #' 18 | #' @param data Proton correlator matrix 19 | #' @param bc String. Boundary conditions, default 'antiperiodic' 20 | #' @param twistangle Numeric. Angle in twisted boundary conditions. 21 | #' 22 | #' @return 23 | #' Returns a \link{data.frame} with two columns, the first the forward and 24 | #' the second the backward propagating proton correlation function. 25 | #' 26 | #' @export 27 | proton <- function(data, bc="antiperiodic", twistangle=0) { 28 | 29 | Time <- max(data[,1])+1 30 | Thalf <- Time/2 31 | 32 | datasum <- cbind(data$V2+1i*data$V3, data$V4+1i*data$V5, data$V6+1i*data$V7, data$V8+1i*data$V9) 33 | 34 | # forward in time we need to project with (One+Gamma4) 35 | # backward in time with (One-Gamma4) 36 | # 37 | # in case of twisted mass: 38 | # u^T Cg_5 d u_i needs twist rotation on index i 39 | # so rotate with exp(\pmi \omega \gamma5/5) as 40 | # appropriate 41 | # 42 | # in case of antiperiodic BC in time: 43 | # in the dynamical update code the APBC are implemented as phase factors 44 | # at each t, so multiply with 45 | # exp(3*i*t*pi/T) 46 | # where the 3 comes from the three involved quarks. 47 | 48 | if(bc == "antiperiodic") { 49 | for(t in 1:Time) { 50 | datasum[(4*t-3):(4*t),] = exp(1i*3.*t*pi/Time)*datasum[(4*t-3):(4*t),] 51 | } 52 | } 53 | 54 | s <- sin(twistangle/2) 55 | c <- cos(twistangle/2) 56 | Cor <- rep(0., times=Thalf) 57 | Cor2 <- rep(0., times=Thalf) 58 | Cor[1] <- Re(sum(diag((One + Gamma4) %*% (c*One+1i*s*Gamma5) 59 | %*% datasum[(1:4),] %*% (c*One+1i*s*Gamma5) 60 | %*% (One + Gamma4))))/4 61 | Cor2[1] <- Re(sum(diag((One - Gamma4) %*% (c*One+1i*s*Gamma5) 62 | %*% datasum[(1:4),] %*% (c*One+1i*s*Gamma5) 63 | %*% (One - Gamma4))))/4 64 | for(t in 2:(Thalf+1)) { 65 | Cor[t] <- Re(sum(diag( 66 | 0.5* (((One + Gamma4) %*% (c*One+1i*s*Gamma5) 67 | %*% datasum[((4*t-3):(4*t)),] %*% (c*One+1i*s*Gamma5) 68 | %*% (One + Gamma4)) 69 | + ((One - Gamma4) %*% (c*One+1i*s*Gamma5) 70 | %*% datasum[((4*(Time-t+2)-3):(4*(Time-t+2))),] 71 | %*% (c*One+1i*s*Gamma5) %*% (One - Gamma4)) 72 | ) 73 | )))/4 74 | 75 | Cor2[t] <- Re(sum(diag( 76 | 0.5* ((One - Gamma4) %*% (c*One+1i*s*Gamma5) 77 | %*% datasum[((4*t-3):(4*t)),] %*% (c*One+1i*s*Gamma5) 78 | %*% (One - Gamma4) 79 | + (One + Gamma4) %*% (c*One+1i*s*Gamma5) 80 | %*% datasum[((4*(Time-t+2)-3):(4*(Time-t+2))),] 81 | %*% (c*One+1i*s*Gamma5) %*% (One + Gamma4) 82 | ) 83 | )))/4 84 | 85 | } 86 | return(data.frame(Cor, Cor2)) 87 | } 88 | -------------------------------------------------------------------------------- /vignettes/jackknife_error_normalization.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Jackknife Error Normalization" 3 | author: "Martin Ueding" 4 | output: 5 | rmarkdown::html_vignette 6 | 7 | vignette: > 8 | %\VignetteIndexEntry{Jackknife Error Normalization} 9 | %\VignetteEngine{knitr::rmarkdown} 10 | \usepackage[utf8]{inputenc} 11 | --- 12 | 13 | # Standard deviation 14 | 15 | The standard deviation over the bootstrap samples $X$ is defined as 16 | $$ \mathop{\mathrm{sd}}(X) = \sqrt{\frac{1}{N - 1} \sum_{i = 1}^N (x_i - \bar x_.)^2} \,. $$ 17 | 18 | In the notation $\bar x_.$ the bar means that averaging has been performed over the indices that are replaced by periods. 19 | 20 | The jackknife error over the jackknife samples $Y$ is defined as 21 | $$ \mathop{\mathrm{jse}}(Y) = \sqrt{\frac{N - 1}{N} \sum_{i = 1}^N (y_i - \bar y_.)^2} \,. $$ 22 | 23 | From the equations we expect a factor $\sqrt{(N-1)^2 / N}$ between the two. We can therefore expect to express the jackknife error simply as 24 | $$ \mathop{\mathrm{jse}}(Y) = \sqrt{\frac{(N-1)^2}{N}} \mathop{\mathrm{sd}}(Y) \,. $$ 25 | 26 | We want to test this numerically using the implementation of the second equation. 27 | 28 | ```{r} 29 | jackknife_error <- function (samples, na.rm = FALSE) { 30 | ## Number of jackknife samples. 31 | N <- length(samples) 32 | 33 | if (na.rm) { 34 | selection <- !is.na(samples) 35 | samples <- samples[selection] 36 | 37 | ## Number of non-NA samples. 38 | m <- sum(selection) 39 | factor <- N / m 40 | } else { 41 | factor <- 1.0 42 | } 43 | 44 | sqrt(factor * (N - 1) / N * sum((samples - mean(samples))^2)) 45 | } 46 | ``` 47 | 48 | Using a little data set we conclude that we got the factor right. 49 | 50 | ```{r} 51 | N = 10 52 | data = rnorm(N) 53 | 54 | be = sd(data) 55 | je = jackknife_error(data) 56 | expected_factor = sqrt((N-1)^2 / N) 57 | actual_factor = je / be 58 | 59 | actual_factor / expected_factor 60 | ``` 61 | 62 | # Covariance 63 | 64 | The covariance is similarly defined, and we have the same normalization factor that we need to take care of. Since the diagonal elements of the covariance matrix are the variances, we need to apply the same normalization factor. The big complication is that the R `cov` function can either be called with one matrix or two vectors. We need to support both for the jackknife such that it has the same API. 65 | 66 | ```{r} 67 | jackknife_cov <- function (x, y = NULL, na.rm = FALSE, ...) { 68 | factor <- 1.0 69 | 70 | if (is.null(y)) { 71 | N <- nrow(x) 72 | if (na.rm) { 73 | na_values <- apply(x, 2, function (row) any(is.na(row))) 74 | m <- sum(na_values) 75 | x <- x[!na_values, ] 76 | factor <- N / m 77 | } 78 | } else { 79 | N <- length(x) 80 | if (na.rm) { 81 | na_values <- is.na(x) | is.na(y) 82 | m <- sum(na_values) 83 | x <- x[!na_values] 84 | y <- y[!na_values] 85 | factor <- N / m 86 | } 87 | } 88 | 89 | (N-1)^2 / N * factor * cov(x, y, ...) 90 | } 91 | ``` 92 | 93 | ```{r} 94 | x <- rnorm(10) 95 | y <- rnorm(10) 96 | 97 | cov(x, y) 98 | jackknife_cov(x, y) 99 | 100 | cov(cbind(x, y)) 101 | jackknife_cov(cbind(x, y)) 102 | ``` 103 | 104 | ```{r} 105 | x <- rnorm(1000) 106 | 107 | jackknife_samples_1 <- sapply(1:length(x), function (i) mean(x[-i])) 108 | jackknife_samples_2 <- sapply(2:length(x), function (i) mean(x[-c(i-1, i)])) 109 | 110 | jse1 <- jackknife_error(jackknife_samples_1) 111 | jse2 <- jackknife_error(jackknife_samples_2) 112 | 113 | jse2/jse1 114 | ``` 115 | 116 | -------------------------------------------------------------------------------- /exec/old/variational.R: -------------------------------------------------------------------------------- 1 | #' variational analysis of a correlator matrix 2 | #' 3 | #' variational analysis of a correlator matrix 4 | #' 5 | #' 6 | #' @param Cor correlator matrix 7 | #' @param ta first time value for eigenvector determination 8 | #' @param tb second time value for eigenvector determination 9 | #' @param tmax maximal time value to be considered in the analysis 10 | #' @param N matrix size. must be <= to the size of the correlator matrix 11 | #' @param T1 maximal time value in correlator matrix 12 | #' @param matrix.size matrix size to be used for start value determination 13 | #' (e.g. for pionfit) 14 | #' @param no.masses number of mass values for start value determination 15 | #' @return returns a list with following entries \item{t}{ the list of time 16 | #' values } \item{res.values}{ the mass values in a \code{tmax-ta} times 17 | #' \code{N} array for all analysed t-values } \item{par}{ startvalues for a fit 18 | #' } \item{variational.masses}{ the list of mass values as determined from the 19 | #' variational analysis } 20 | #' @author Carsten Urbach, \email{carsten.urbach@@physik.hu-berlin.de} 21 | #' @seealso pion 22 | #' @keywords variational 23 | variational <- function(Cor, ta, tb, tmax, N, T1, matrix.size, no.masses) { 24 | 25 | ta=ta+1 26 | tb=tb+1 27 | if(ta > tb) { 28 | tmp <- ta 29 | ta <- tb 30 | tb <- tmp 31 | } 32 | res.values <- array(0., dim=c(tmax-ta,N)) 33 | Ca <- getNxNmatrix(Cor=Cor, t=ta, T1=T1, N=N) 34 | Cb <- getNxNmatrix(Cor=Cor, t=tb, T1=T1, N=N) 35 | C3 <- getNxNmatrix(Cor=Cor, t=tb, T1=T1, N=N) 36 | 37 | # first index is rows, second columns 38 | Ca.inv <- solve(Ca) 39 | C3 <- Ca.inv %*% Cb 40 | variational.solve <- eigen(C3, symmetric=FALSE, only.values = FALSE, EISPACK=FALSE) 41 | # check and sort eigenvalues 42 | for(i in 1:N) { 43 | if(abs(variational.solve$values[i]) > 0.95/(tb-ta)) { 44 | variational.solve$values[i] <- 0.0001 45 | } 46 | } 47 | sortindex <- order(-log(abs(variational.solve$values)*(tb-ta))) 48 | # get the left eigenvectors, the eigenvectors have unit length 49 | # this does not quite work for the pion ? 50 | left.vectors <- crossprod(Ca, variational.solve$vectors) 51 | 52 | X <- crossprod(left.vectors, variational.solve$vectors) 53 | for(i in 1:N) { 54 | # left.vectors[,i] <- left.vectors[,i]/X[i,i] 55 | variational.solve$vectors[,i] <- variational.solve$vectors[,i]/X[i,i] 56 | } 57 | variational.masses <- -log(abs(variational.solve$values[sortindex]))/(tb-ta) 58 | for(t in tb:(tmax)) { 59 | values <- numeric(N) 60 | ca <- getNxNmatrix(Cor=Cor, t=t-1, T1=T1, N=N) 61 | cb <- getNxNmatrix(Cor=Cor, t=t, T1=T1, N=N) 62 | # first index is rows, second columns 63 | ca.inv <- solve(ca) 64 | c3 <- ca.inv %*% cb 65 | X <- crossprod(left.vectors, c3 %*% variational.solve$vectors) 66 | for(j in 1:N) { 67 | values[j] <- X[j,j] 68 | } 69 | rm(X) 70 | ## message(ta, " ", tb, " ", variational.masses, " ", variational.solve$values, "\n") 71 | res.values[t-ta,] <- -log(abs(values[sortindex])) 72 | } 73 | 74 | par <- c(2*left.vectors[(1:matrix.size),sortindex[1]], 75 | -log(abs(variational.solve$values[sortindex[1]]))/(tb-ta)) 76 | if(no.masses > 1) { 77 | for(i in 2:(no.masses)) { 78 | par <- c(par, 79 | 2*left.vectors[(1:matrix.size),sortindex[i]], 80 | -log(abs(variational.solve$values[sortindex[i]]))/(tb-ta)) 81 | } 82 | } 83 | 84 | return(invisible(list(t=c(tb:tmax), res.values=res.values, par=par, 85 | variational.masses = variational.masses))) 86 | 87 | } 88 | 89 | -------------------------------------------------------------------------------- /exec/old/ana.R: -------------------------------------------------------------------------------- 1 | anaoutput <- function(data, from, to, npsf = 2, S=1.5) { 2 | 3 | plaq <- uwerrprimary(data$V1[from:to], plot=FALSE, S=S) 4 | dH <- uwerrprimary(data$V2[from:to]*data$V2[from:to], plot=FALSE, S=S) 5 | edH <- uwerrprimary(data$V3[from:to], plot=FALSE, S=S) 6 | iter0 <- uwerrprimary(data$V4[from:to]+data$V5[from:to]+data$V6[from:to], plot=FALSE, S=S) 7 | if(npsf == 1) { 8 | iter <- iter0 9 | acc <- uwerrprimary(data$V7[from:to], plot=FALSE, S=S); 10 | cat(plaq$value, plaq$dvalue, plaq$ddvalue, plaq$tauint, plaq$dtauint, iter$value, iter$dvalue, acc$value, acc$dvalue, edH$value, edH$dvalue, sqrt(dH$value), sqrt((dH$dvalue)^2/4./dh$value), "\n") 11 | } 12 | 13 | if(npsf == 2) { 14 | iter1 <- uwerrprimary(data$V7[from:to]+data$V8[from:to]+data$V9[from:to], plot=FALSE, S=S) 15 | iter <-uwerrprimary(data$V4[from:to]+data$V5[from:to]+data$V6[from:to]+data$V7[from:to]+data$V8[from:to]+data$V9[from:to], plot=FALSE, S=S) 16 | acc <- uwerrprimary(data$V10[from:to], plot=FALSE, S=S); 17 | cat(plaq$value, plaq$dvalue, plaq$ddvalue, plaq$tauint, plaq$dtauint, iter$value, iter$dvalue, acc$value, acc$dvalue, edH$value, sqrt(dH$value), sqrt((dH$dvalue)^2/4./dh$value), "\n") 18 | } 19 | if (npsf == 3) { 20 | iter1 <- uwerrprimary(data$V7[from:to]+data$V8[from:to]+data$V9[from:to], plot=FALSE, S=S) 21 | iter2 <- uwerrprimary(data$V10[from:to]+data$V11[from:to]+data$V12[from:to], plot=FALSE, S=S) 22 | iter <-uwerrprimary(data$V4[from:to]+data$V5[from:to]+data$V6[from:to]+data$V7[from:to]+data$V8[from:to]+data$V9[from:to]+data$V10[from:to]+data$V11[from:to]+data$V12[from:to], 23 | plot=FALSE, S=S) 24 | acc <- uwerrprimary(data$V13[from:to], plot=FALSE, S=S); 25 | # cat(plaq$value, plaq$dvalue, dH$value, dH$dvalue, acc$value, acc$dvalue, ddH$value, ddH$dvalue, ddU$value, ddU$Dvalue, iter$value, iter$dvalue, iter0$value, iter0$dvalue, iter1$value, iter1$dvalue, iter2$value, iter2$dvalue, "\n", file="res.dat") 26 | cat(plaq$value, plaq$dvalue, plaq$ddvalue, plaq$tauint, plaq$dtauint, iter$value, iter$dvalue, acc$value, acc$dvalue, edH$value, sqrt(dH$value), sqrt((dH$dvalue)^2/4./dh$value), "\n") 27 | } 28 | 29 | } 30 | 31 | anaoutputaver <- function(file = "output.data", npsf = 2) { 32 | 33 | data <- read.table(file); 34 | ret <- read.table("return_check.data") 35 | plaq <- average(data$V1) 36 | dH <- average(data$V2*data$V2) 37 | iter0 <- average(data$V4+data$V5+data$V6) 38 | ddH <- average(sqrt(ret$V3*ret$V3)) 39 | ddU <- average(ret$V5) 40 | if(npsf == 1) { 41 | iter <- iter0 42 | acc <- average(data$V7) 43 | cat(plaq$value, plaq$dvalue, sqrt(dH$value), sqrt((dH$dvalue)^2/4/dH$value), acc$value, acc$dvalue, ddH$value, ddH$dvalue, ddU$value, ddU$dvalue, iter0$value, iter0$dvalue, "\n", file="res.dat") 44 | } 45 | 46 | if(npsf == 2) { 47 | iter1 <- average(data$V7+data$V8+data$V9) 48 | iter <-average(data$V4+data$V5+data$V6+data$V7+data$V8+data$V9) 49 | acc <- average(data$V10) 50 | cat(plaq$value, plaq$dvalue, sqrt(dH$value), sqrt((dH$dvalue)^2/4/dH$value), acc$value, acc$dvalue, ddH$value, ddH$dvalue, ddU$value, ddU$dvalue, iter$value, iter$dvalue, iter0$value, iter0$dvalue, iter1$value, iter1$dvalue, "\n", file="res.dat") 51 | } 52 | if (npsf == 3) { 53 | iter1 <- average(data$V7+data$V8+data$V9) 54 | iter2 <- average(data$V10+data$V11+data$V12) 55 | iter <-average(data$V4+data$V5+data$V6+data$V7+data$V8+data$V9+data$V10+data$V11+data$V12) 56 | acc <- average(data$V13) 57 | cat(plaq$value, plaq$dvalue, sqrt(dH$value), sqrt((dH$dvalue)^2/4/dH$value), acc$value, acc$dvalue, ddH$value, ddH$dvalue, ddU$value, ddU$Dvalue, iter$value, iter$dvalue, iter0$value, iter0$dvalue, iter1$value, iter1$dvalue, iter2$value, iter2$dvalue, "\n", file="res.dat") 58 | } 59 | 60 | } 61 | -------------------------------------------------------------------------------- /exec/phaseshift/phaseshift.pipiswave.R: -------------------------------------------------------------------------------- 1 | ## version with continuums dispersion relation 2 | compute.gamma.free2 <- function(mpisq, p1=c(0,0,0), p2=c(0,0,0), L, dvec) { 3 | E <- sqrt(mpisq + sum((p1*2*pi/L)^2)) + sqrt(mpisq+sum((p2*2*pi/L)^2)) 4 | ##cat("E non-interacting", sqrt(mpisq + sum((p1*2*pi/L)^2)) + sqrt(mpisq+sum((p2*2*pi/L)^2)), "\n") 5 | return(E/sqrt(E^2 - sum((2*pi*dvec/L)^2))) 6 | } 7 | 8 | ## version with lattice dispersion relation 9 | compute.gamma.free <- function(mpisq, p1, p2, L, dvec) { 10 | cmpi <- cosh(sqrt(mpisq)) 11 | E <- acosh(cmpi + 2*sum(sin(pi*p1/L)^2)) + acosh(cmpi + 2*sum(sin(pi*p2/L)^2)) 12 | Ecm <- acosh(cosh(E) - 2*sum(sin(pi*dvec/L)^2)) 13 | return(E/Ecm) 14 | } 15 | 16 | phaseshift.pipi.swave <- function(PC="pc1", tp="TP0", 17 | p1=c(0,0,0), p2=c(0,0,0), dr=c(-1, 1), 18 | boot.R=400, boot.l=1, L=32, T=64, dvec=c(0,0,0), debug=FALSE 19 | ) { 20 | l <- 0 21 | m <- 0 22 | ## dvec needs to be defined as the direction vector for the total momentum 23 | cat("...determining phase shift from energy levels for", PC, "\n") 24 | cat("momentum vector:", dvec, "\n") 25 | pionfilelist <- Sys.glob("pion.p0.effectivemass.*.Rdata") 26 | pipifilelist <- Sys.glob(paste(PC, ".", tp, ".effectivemass.*.Rdata", sep="")) 27 | 28 | res <- array(0., dim=c(boot.R+1, length(pionfilelist), length(pipifilelist), 8)) 29 | 30 | cat("\n...determining shifts for", length(pionfilelist), "x", length(pipifilelist), "combinations\n") 31 | for(i in c(1:length(pionfilelist))) { 32 | load(pionfilelist[i]) 33 | for(j in c(1:length(pipifilelist))) { 34 | cat(i, j, pionfilelist[i], pipifilelist[j], "\n") 35 | 36 | load(pipifilelist[j]) 37 | if(pc.effectivemass$boot.R != pion.effectivemass$boot.R) stop("number of boostrap samples does not match. Aborting ...\n") 38 | 39 | qtsq <- compute.qtildesq(pc.effectivemass$opt.res$par[1], dvec=dvec, L=L, mpi=pion.effectivemass$opt.res$par[1]) 40 | 41 | Z <- try(LuescherZeta(qtsq$qtsq, l=l, m=m, gamma=qtsq$gammaboost, dvec=dvec)) 42 | if(inherits(Z, "try-error")) Z <- SplineReZ(qtsq$qtsq) 43 | Z <- Re(Z) 44 | qcotdelta <- 2.*Z/(qtsq$gammaboost*L*sqrt(pi)) 45 | delta <- atan(qtsq$q/qcotdelta)*180/pi 46 | res[1, i, j, ] <- c(qtsq$q^2, qtsq$qtsq, qcotdelta, delta, pion.effectivemass$opt.res$par[1], pc.effectivemass$opt.res$par[1], 47 | pion.effectivemass$Qval, pc.effectivemass$Qval) 48 | 49 | ## now we bootstrap 50 | qtsq <- compute.qtildesq(pc.effectivemass$massfit.tsboot[,1], dvec=dvec, L=L, mpi=pion.effectivemass$massfit.tsboot[,1]) 51 | 52 | Z <- Re(LuescherZeta(qtsq$qtsq, l=l, m=m, gamma=qtsq$gammaboost, dvec=dvec)) 53 | res[c(2:(boot.R+1)), i, j, 1] <- qtsq$q^2 54 | res[c(2:(boot.R+1)), i, j, 2] <- qtsq$qtsq 55 | ## q cot(delta) 56 | res[c(2:(boot.R+1)), i, j, 3] <- 2.*Z/(qtsq$gammaboost*L*sqrt(pi)) 57 | ## delta 58 | res[c(2:(boot.R+1)), i, j, 4] <- atan(qtsq$q/res[c(2:(boot.R+1)), i, j, 3])*180/pi 59 | ## Epi 60 | res[c(2:(boot.R+1)), i, j, 5] <- pion.effectivemass$massfit.tsboot[,1] 61 | ## Epipi 62 | res[c(2:(boot.R+1)), i, j, 6] <- pc.effectivemass$massfit.tsboot[,1] 63 | ## p-value pion effective mass fit 64 | res[c(2:(boot.R+1)), i, j, 7] <- 1-pchisq(pion.effectivemass$massfit.tsboot[,2], pion.effectivemass$dof) 65 | ## p-value pipi effective mass fit 66 | res[c(2:(boot.R+1)), i, j, 8] <- 1-pchisq(pc.effectivemass$massfit.tsboot[,2], pc.effectivemass$dof) 67 | if(debug) cat("qcotdelta = ", qcotdelta, "; delta = ", delta, "\n") 68 | } 69 | save(res, file=paste("res.", PC, ".", tp, ".Rdata", sep="")) 70 | } 71 | return(invisible(res)) 72 | } 73 | -------------------------------------------------------------------------------- /R/tikzutils.R: -------------------------------------------------------------------------------- 1 | #' tikz.init 2 | #' 3 | #' Convenience Functions for \code{tikzDevice} 4 | #' 5 | #' @description 6 | #' initialize and finalize a \code{tikzDevice} and carry out optional 7 | #' post-processing 8 | #' 9 | #' @param basename the base of the files which will be used by 10 | #' \code{tikzDevice}, e.g. "basename" -> "basename.pdf", etc. 11 | #' @param ... optional arguments which are passed to \code{tikz}, see 12 | #' \code{\link[tikzDevice:tikz]{tikzDevice::tikz}} 13 | #' @param standAlone A logical value indicating whether the output file should 14 | #' be suitable for direct processing by LaTeX. A value of \code{FALSE} 15 | #' indicates that the file is intended for inclusion in a larger document. 16 | #' @param engine used to specify the LaTex engine. If missing, the standard 17 | #' engine of tikz is used. 18 | #' @return \code{tikz.init} returns a list with character vector members, $pdf, 19 | #' $tex, $aux $log containing the corresponding filenames 20 | #' @author Bartosz Kostrzewa, \email{bartosz.kostrzewa@@desy.de} 21 | #' @keywords file 22 | #' 23 | #' @family tikzutils 24 | #' @examples 25 | #' 26 | #' \donttest{tikzfiles <- tikz.init("plotname",width=3,height=4)} 27 | #' \donttest{plot(x=c(1:3), y=c(1:3)^2, xlab="$x$", ylab="$y$")} 28 | #' \donttest{tikz.finalize(tikzfiles=tikzfiles, clean=TRUE)} 29 | #' \donttest{file.remove("plotname.pdf")} 30 | #' 31 | #' @export 32 | tikz.init <- function(basename, standAlone = TRUE, engine, ...) { 33 | havetikz <- requireNamespace("tikzDevice") 34 | if(!havetikz){ 35 | stop("tikz.init: tikzDevice package was not found!") 36 | } 37 | if(missing(engine)) { 38 | engine <- getOption("tikzDefaultEngine") 39 | } 40 | 41 | temp <- sprintf("%s.%s",basename,c("tex","pdf","aux","log")) 42 | tikzfiles <- list(tex=temp[1], pdf=temp[2], aux=temp[3], log=temp[4], standAlone=standAlone) 43 | tikzDevice::tikz(tikzfiles$tex, standAlone = standAlone, engine=engine, ...) 44 | tikzfiles 45 | } 46 | 47 | #' tikz.finalize 48 | #' 49 | #' Convenience Functions for \code{tikzDevice} 50 | #' 51 | #' @description 52 | #' initialize and finalize a \code{tikzDevice} and carry out optional 53 | #' post-processing 54 | #' 55 | #' @param tikzfiles a list with members $pdf, $tex, $aux and $log, returned by 56 | #' \code{tikz.init} which must be passed to \code{tikz.finalize} 57 | #' @param crop boolean indicating whether \code{pdfcrop} should be called on 58 | #' the resulting pdf ( existence of \code{pdfcrop} is checked before the 59 | #' command is called ), default TRUE 60 | #' @param margins margins argument for pdfcrop command, should be passed as a 61 | #' string consisting of one or multiple numbers (e.g. "10" or "10.5 7.5 6.2 62 | #' 10"), default 0 63 | #' @param clean boolean indicating whether temporary files, e.g. 64 | #' "basename.tex", "basename.aux" and "basename.log" should be deleted after 65 | #' the pdf has been generated, default TRUE 66 | #' @author Bartosz Kostrzewa, \email{bartosz.kostrzewa@@desy.de} 67 | #' @keywords file 68 | #' 69 | #' @seealso \code{\link{tikz.init}} 70 | #' @family tikzutils 71 | #' 72 | #' @return 73 | #' No return value, but the output PDF will be created and cropped. 74 | #' 75 | #' @export 76 | tikz.finalize <- function(tikzfiles, crop=TRUE, margins=0, clean=TRUE) { 77 | dev.off() 78 | if(tikzfiles$standAlone) { 79 | tools::texi2dvi(tikzfiles$tex, pdf=T) 80 | if(crop){ 81 | ## use pdfcrop tool to remove plot borders 82 | if( Sys.which("pdfcrop") != "" ){ 83 | command <- sprintf("pdfcrop --margins=%s %s %s",margins,tikzfiles$pdf,tikzfiles$pdf) 84 | system(command) 85 | } 86 | else { 87 | warning(sprintf("tikz_finalize: crop requested for %s but 'pdfcrop' tool not found!",tikzfiles$pdf)) 88 | } 89 | } 90 | if(clean){ 91 | ## remove temporary files 92 | command <- sprintf("rm %s %s %s", tikzfiles$tex, tikzfiles$log, tikzfiles$aux) 93 | system(command) 94 | } 95 | } 96 | } 97 | 98 | 99 | -------------------------------------------------------------------------------- /inst/weighted_model.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Weighted Models" 3 | output: pdf_document 4 | 5 | vignette: > 6 | %\VignetteIndexEntry{Weighted Models} 7 | %\VignetteEngine{knitr::rmarkdown} 8 | \usepackage[utf8]{inputenc} 9 | --- 10 | 11 | We have the “weighted” model. It is implemented for the effective mass but not yet for the correlator fit. Also we want to extend this to $\delta t \neq 1$. In this document we will derive the exact model in the general case to figure out what the weight factor $w$ has to be exactly. 12 | 13 | ```{r setup} 14 | devtools::load_all() 15 | library(hadron) 16 | ``` 17 | 18 | # Analytic considerations 19 | 20 | Let us assume that we have a perfect signal with energy $E_0 > 0$ amplitude and $A_0$. Additional there is a single thermal state with $E_1 > 0$ and $A_1$. We can therefore write the model as 21 | $$ C(t) = A_0 \left[ \exp(-E_0 t) + \exp(-E_0 (T - t)) \right] + A_1 \left[ \exp(-E_1 t) + \exp(-E_1 (T - t)) \right] \,. $$ 22 | 23 | If the thermal pollution was constant ($E_1 = 0$), we could just shift it away. But in this case of a time dependence, we first need to *weight* that away before we do the shift. We multiply the correlation function with the inverse of time dependence of the pollution, so we have 24 | $$ C_\mathrm{w}(t) = C(t) * \left[ \exp(E_1 t) + \exp(E_1 (T - t)) \right] = A_0 \left[ \exp(-E_0 t) + \exp(-E_0 (T - t)) \right] + A_1 \left[ \exp(-E_1 t) + \exp(-E_1 (T - t)) \right] $$ 25 | 26 | 27 | # Synthetic data 28 | 29 | First we generate some synthetic data which contains exactly what we want: A one-state correlation function with energy $E_0$ and amplitude $A_0$. Then we add a single thermal state with energy $E_1 < 0$ and amplitude $A_2$. We add just a little bit of gaussian noise to generate measurements from that. The plot shows the central values that we use. 30 | 31 | ```{r} 32 | E_0 <- 0.25 33 | A_0 <- 1.34 34 | E_1 <- -0.03 35 | A_1 <- 0.00003 36 | 37 | n_meas <- 500 38 | extent_time <- 96 39 | 40 | tt <- 0:(extent_time - 1) 41 | 42 | cf0_signal <- A_0 * (exp(- E_0 * tt) + exp(- E_0 * (extent_time - tt))) 43 | cf0_thermal <- A_1 * (exp(- E_1 * tt) + exp(- E_1 * (extent_time - tt))) 44 | cf0 <- cf0_signal + cf0_thermal 45 | cf <- do.call(cbind, lapply(cf0, function (m) rnorm(n_meas, m, 0.05 * m))) 46 | 47 | corr <- cf_meta(Time = extent_time) 48 | corr <- cf_orig(corr, cf = cf) 49 | 50 | plot(tt, cf0, 51 | main = 'Central generation values', 52 | xlab = 'Time', 53 | ylab = 'Correlator', 54 | log = 'y', 55 | type = 'l', 56 | ylim = range(cf0, cf0_signal, cf0_thermal)) 57 | lines(tt, cf0_signal, col = 'blue') 58 | lines(tt, cf0_thermal, col = 'red') 59 | legend('top', c('Both', 'Signal', 'Thermal'), col = c('black', 'blue', 'red'), pch = 1) 60 | ``` 61 | 62 | This correlation function has a nice single state and a sizable thermal state in the end. 63 | 64 | ```{r} 65 | boot_R <- 1500 66 | 67 | corr_sym <- symmetrise.cf(corr) 68 | corr_boot <- bootstrap.cf(corr_sym, boot.R = boot_R, boot.l = 1, seed = 0) 69 | 70 | plot(corr_boot, log = 'y') 71 | ``` 72 | 73 | We can see that the effective mass undershoots the signal value that we have put in. 74 | 75 | ```{r} 76 | effmass <- bootstrap.effectivemass(corr_boot, type = 'solve') 77 | plot(effmass, ylim = c(0, E_0), 78 | main = '“Solve” effective mass', xlab = 'Time', ylab = 'Effective Mass') 79 | abline(h = E_0, col = 'red') 80 | ``` 81 | 82 | Now we do a weight-shift-reweight with the masses that we put in. We see that the correlator looks much better afterwards and the effective mass is just what the expect from the sigal. 83 | 84 | ```{r} 85 | corr_rt <- weight_shift_reweight.cf(corr_boot, E_1, rep(E_1, boot_R), +1) 86 | plot(corr_rt, log = 'y') 87 | 88 | effmass_rt <- bootstrap.effectivemass(corr_rt, type = 'weighted') 89 | plot(effmass_rt, 90 | xlab = 'Time', ylab = 'Effective mass', 91 | main = '“Weighted” effective mass') 92 | abline(h = E_0, col = 'red') 93 | ``` 94 | 95 | The removal seemed to have worked out nicely. 96 | -------------------------------------------------------------------------------- /exec/mesons-cmi/summary.a0fit.R: -------------------------------------------------------------------------------- 1 | print.a0fit <- function(fit) { 2 | summary(fit) 3 | } 4 | 5 | summary.a0fit <- function(fit) { 6 | kappa <- fit$kappa 7 | mu <- fit$mu 8 | t1 <- fit$t1 9 | t2 <- fit$t2 10 | ij <- seq(1, fit$no.masses*(fit$matrix.size+1), by=fit$matrix.size+1) 11 | sortindex <- order(abs(fit$fitresult$par[ij+fit$matrix.size])) 12 | ii <- ij[sortindex] 13 | 14 | fit.mass <- abs(fit$fitresult$par[ii[1] + fit$matrix.size]) 15 | fit.chisqr <- fit$fitresult$value 16 | fit.dof <- length(fit$fitdata$t)-length(fit$fitresult$par) 17 | 18 | cat("mu = ", mu, "\n") 19 | cat("kappa = ", kappa, "\n") 20 | cat("No of measurements = ", fit$N, "\n") 21 | cat("No of replica = ", length(fit$nrep), "\n") 22 | cat("no or measurements per replicum: ", fit$nrep, "\n") 23 | cat("fitrange = ", t1, "-", t2, "\n") 24 | cat("chi^2 = ", fit.chisqr, "\n") 25 | cat("dof = ", fit.dof, "\n") 26 | cat("chi^2/dof = ", fit.chisqr/fit.dof, "\n") 27 | 28 | if(fit$no.masses == 1) { 29 | cat("ma0 = ", fit.mass, "\n") 30 | } 31 | 32 | cat("\nstate =", seq(1,fit$no.masses), "\n", sep="\t") 33 | cat("masses =", abs(fit$fitresult$par[ii+fit$matrix.size]), "\n", sep="\t") 34 | cat("B_L =", fit$fitresult$par[ii], "\n", sep="\t") 35 | cat("B_F =", fit$fitresult$par[ii+1], "\n", sep="\t") 36 | 37 | if(!is.null(fit$uwerrresultma0)) { 38 | cat("\n--- Autocorrelation analysis for ma0 ---\n") 39 | cat("\nS = ", fit$uwerrresultma0$S, "\n") 40 | cat("ma0 = ", fit$uwerrresultma0$value, "\n") 41 | cat("dma0 = ", fit$uwerrresultma0$dvalue, "\n") 42 | cat("ddma0 = ", fit$uwerrresultma0$ddvalue, "\n") 43 | cat("tauint = ", fit$uwerrresultma0$tauint, "\n") 44 | cat("dtauint = ", fit$uwerrresultma0$dtauint, "\n") 45 | cat("Wopt = ", fit$uwerrresultma0$Wopt, "\n") 46 | if(fit$uwerrresultma0$R>1) { 47 | cat("Qval =", fit$uwerrresultma0$Qval, "\n") 48 | } 49 | if(fit$no.masses > 1) { 50 | cat("\n--- Autocorrelation analysis for ma0 ---\n") 51 | cat("\nS = ", fit$uwerrresultma02$S, "\n") 52 | cat("ma02 = ", fit$uwerrresultma02$value, "\n") 53 | cat("dma02 = ", fit$uwerrresultma02$dvalue, "\n") 54 | cat("ddma02 = ", fit$uwerrresultma02$ddvalue, "\n") 55 | cat("tauint2 = ", fit$uwerrresultma02$tauint, "\n") 56 | cat("dtauint2 = ", fit$uwerrresultma02$dtauint, "\n") 57 | cat("Wopt2 = ", fit$uwerrresultma02$Wopt, "\n") 58 | if(fit$uwerrresultma02$R>1) { 59 | cat("Qval =", fit$uwerrresultma02$Qval, "\n") 60 | } 61 | } 62 | } 63 | 64 | if(!is.null(fit$boot)) { 65 | cat("--- Bootstrap analysis ---\n") 66 | cat("---", fit$boot$R, "samples ---\n") 67 | cat(" mean -err +err stderr bias\n") 68 | for(no in 1:fit$no.masses) { 69 | index <- (no-1)*(fit$matrix.size+1)+1 70 | b.ci <- boot.ci(fit$boot, type = c("norm"), index=index) 71 | cat("ma0[",no,"] = ", abs(fit$boot$t0[index]), "(", (b.ci$normal[1,2]-fit$boot$t0[index])/1.96 72 | , ",", -(fit$boot$t0[index]-b.ci$normal[1,3])/1.96, ")", sd(fit$boot$t[,index]), 73 | mean(fit$boot$t[,index])-fit$boot$t0[index],"\n") 74 | } 75 | } 76 | if(!is.null(fit$tsboot)) { 77 | cat("\n--- Bootstrap analysis with blocking ---\n") 78 | cat("---", fit$tsboot$R, "samples ---\n") 79 | cat("--- block size", fit$tsboot$l, "---\n") 80 | for(no in 1:fit$no.masses) { 81 | index <- (no-1)*(fit$matrix.size+1)+1 82 | tsb.ci <- boot.ci(fit$tsboot, type = c("norm"), index=index) 83 | cat("ma0[",no,"] = ", fit$tsboot$t0[index], "(", (tsb.ci$normal[1,2]-fit$tsboot$t0[index])/1.96 84 | , ",", -(fit$tsboot$t0[index]-tsb.ci$normal[1,3])/1.96, ")", sd(fit$tsboot$t[,index]), 85 | mean(fit$tsboot$t[,index])-fit$tsboot$t0[index], "\n") 86 | } 87 | } 88 | if(!is.null(fit$variational.masses)) { 89 | cat("\n--- Variational analysis ---\n") 90 | cat("masses:", fit$variational.masses, "\n") 91 | } 92 | 93 | } 94 | -------------------------------------------------------------------------------- /exec/mesons-cmi/summary.b1fit.R: -------------------------------------------------------------------------------- 1 | print.b1fit <- function(fit) { 2 | summary(fit) 3 | } 4 | 5 | summary.b1fit <- function(fit) { 6 | kappa <- fit$kappa 7 | mu <- fit$mu 8 | t1 <- fit$t1 9 | t2 <- fit$t2 10 | ij <- seq(1, fit$no.masses*(fit$matrix.size+1), by=fit$matrix.size+1) 11 | sortindex <- order(abs(fit$fitresult$par[ij+fit$matrix.size])) 12 | ii <- ij[sortindex] 13 | 14 | fit.mass <- abs(fit$fitresult$par[ii[1] + fit$matrix.size]) 15 | fit.chisqr <- fit$fitresult$value 16 | fit.dof <- length(fit$fitdata$t)-length(fit$fitresult$par) 17 | 18 | cat("mu = ", mu, "\n") 19 | cat("kappa = ", kappa, "\n") 20 | cat("No of measurements = ", fit$N, "\n") 21 | cat("No of replica = ", length(fit$nrep), "\n") 22 | cat("no or measurements per replicum: ", fit$nrep, "\n") 23 | cat("fitrange = ", t1, "-", t2, "\n") 24 | cat("chi^2 = ", fit.chisqr, "\n") 25 | cat("dof = ", fit.dof, "\n") 26 | cat("chi^2/dof = ", fit.chisqr/fit.dof, "\n") 27 | 28 | if(fit$no.masses == 1) { 29 | cat("mb1 = ", fit.mass, "\n") 30 | } 31 | 32 | cat("\nstate =", seq(1,fit$no.masses), "\n", sep="\t") 33 | cat("masses =", abs(fit$fitresult$par[ii+fit$matrix.size]), "\n", sep="\t") 34 | cat("B_L =", fit$fitresult$par[ii], "\n", sep="\t") 35 | cat("B_F =", fit$fitresult$par[ii+1], "\n", sep="\t") 36 | 37 | if(!is.null(fit$uwerrresultmb1)) { 38 | cat("\n--- Autocorrelation analysis for mb1 ---\n") 39 | cat("\nS = ", fit$uwerrresultmb1$S, "\n") 40 | cat("mb1 = ", fit$uwerrresultmb1$value, "\n") 41 | cat("dmb1 = ", fit$uwerrresultmb1$dvalue, "\n") 42 | cat("ddmb1 = ", fit$uwerrresultmb1$ddvalue, "\n") 43 | cat("tauint = ", fit$uwerrresultmb1$tauint, "\n") 44 | cat("dtauint = ", fit$uwerrresultmb1$dtauint, "\n") 45 | cat("Wopt = ", fit$uwerrresultmb1$Wopt, "\n") 46 | if(fit$uwerrresultmb1$R>1) { 47 | cat("Qval =", fit$uwerrresultmb1$Qval, "\n") 48 | } 49 | if(fit$no.masses > 1) { 50 | cat("\n--- Autocorrelation analysis for mb1 ---\n") 51 | cat("\nS = ", fit$uwerrresultmb12$S, "\n") 52 | cat("mb12 = ", fit$uwerrresultmb12$value, "\n") 53 | cat("dmb12 = ", fit$uwerrresultmb12$dvalue, "\n") 54 | cat("ddmb12 = ", fit$uwerrresultmb12$ddvalue, "\n") 55 | cat("tauint2 = ", fit$uwerrresultmb12$tauint, "\n") 56 | cat("dtauint2 = ", fit$uwerrresultmb12$dtauint, "\n") 57 | cat("Wopt2 = ", fit$uwerrresultmb12$Wopt, "\n") 58 | if(fit$uwerrresultmb12$R>1) { 59 | cat("Qval =", fit$uwerrresultmb12$Qval, "\n") 60 | } 61 | } 62 | } 63 | 64 | if(!is.null(fit$boot)) { 65 | cat("--- Bootstrap analysis ---\n") 66 | cat("---", fit$boot$R, "samples ---\n") 67 | cat(" mean -err +err stderr bias\n") 68 | for(no in 1:fit$no.masses) { 69 | index <- (no-1)*(fit$matrix.size+1)+1 70 | b.ci <- boot.ci(fit$boot, type = c("norm"), index=index) 71 | cat("mb1[",no,"] = ", abs(fit$boot$t0[index]), "(", (b.ci$normal[1,2]-fit$boot$t0[index])/1.96 72 | , ",", -(fit$boot$t0[index]-b.ci$normal[1,3])/1.96, ")", sd(fit$boot$t[,index]), 73 | mean(fit$boot$t[,index])-fit$boot$t0[index],"\n") 74 | } 75 | } 76 | if(!is.null(fit$tsboot)) { 77 | cat("\n--- Bootstrap analysis with blocking ---\n") 78 | cat("---", fit$tsboot$R, "samples ---\n") 79 | cat("--- block size", fit$tsboot$l, "---\n") 80 | for(no in 1:fit$no.masses) { 81 | index <- (no-1)*(fit$matrix.size+1)+1 82 | tsb.ci <- boot.ci(fit$tsboot, type = c("norm"), index=index) 83 | cat("mb1[",no,"] = ", fit$tsboot$t0[index], "(", (tsb.ci$normal[1,2]-fit$tsboot$t0[index])/1.96 84 | , ",", -(fit$tsboot$t0[index]-tsb.ci$normal[1,3])/1.96, ")", sd(fit$tsboot$t[,index]), 85 | mean(fit$tsboot$t[,index])-fit$tsboot$t0[index], "\n") 86 | } 87 | } 88 | if(!is.null(fit$variational.masses)) { 89 | cat("\n--- Variational analysis ---\n") 90 | cat("masses:", fit$variational.masses, "\n") 91 | } 92 | 93 | } 94 | -------------------------------------------------------------------------------- /R/fs.mpia0.R: -------------------------------------------------------------------------------- 1 | ## finite size correction to q cot(delta) in the I=2 pipi scattering 2 | ## case from Ref. hep-lat/0601033 3 | ## 4 | ## this formula is valid near threshold only! 5 | ## 6 | ## The difference is defined as Delta = FV - Vinfty 7 | 8 | ## this is the original aymptotic formula Eq (31) from Ref. 9 | ## hep-lat/0601033 10 | ## which can be applied to a0 by using the effective range expansion 11 | ## q*cot(delta) = 1/(-a0) 12 | 13 | 14 | #' Finite Size Corrections to \eqn{q\cot\delta}{qcotdelta} for I=2 15 | #' \eqn{\pi\pi}{pipi} near threshold 16 | #' 17 | #' \code{fs.qcotdelta} computes the finite size corrections to 18 | #' \eqn{q\cot\delta}{qcotdelta} while \code{fs.mpia0} computes the 19 | #' corresponding finite size corrections to \eqn{M_\pi a_0}{Mpi a0} directly 20 | #' using the Gasser Leutwyler result from \eqn{M_\pi}{Mpi}. 21 | #' 22 | #' 23 | #' @param L spatial lattice extent as a scalar variable (must not be a vector) 24 | #' @param mps pion mass as a scalar variable (must not be a vector) 25 | #' @return returns a numeric value representing the finite size correction or 26 | #' in case of \code{fs.a0} the corrected value for a0. 27 | #' @author Carsten Urbach, \email{curbach@@gmx.de} 28 | #' @references For the original formula see Eq. (31) from hep-lat/0601033 29 | #' @examples 30 | #' 31 | #' fs.qcotdelta(mps=0.123, L=24) 32 | #' 33 | #' @export fs.qcotdelta 34 | fs.qcotdelta <- function(mps, L) { 35 | ## the 7th is zero, so we skip sqrt(7) 36 | cn <- c(6, 12, 8, 6, 24, 24, 12) 37 | n <- c(1, sqrt(2), sqrt(3), 2, sqrt(5), sqrt(6), sqrt(8)) 38 | return(-mps/sqrt(2*pi)*sum( cn*exp(-n*mps*L)/sqrt(n*mps*L)*(1-227/(24*n*mps*L)) )) 39 | } 40 | 41 | #' Finite Size Corrections to \eqn{q\cot\delta}{qcotdelta} for I=2 42 | #' \eqn{\pi\pi}{pipi} near threshold 43 | #' 44 | #' \code{fs.qcotdelta} computes the finite size corrections to 45 | #' \eqn{q\cot\delta}{qcotdelta} while \code{fs.mpia0} computes the 46 | #' corresponding finite size corrections to \eqn{M_\pi a_0}{Mpi a0} directly 47 | #' using the Gasser Leutwyler result from \eqn{M_\pi}{Mpi}. 48 | #' 49 | #' 50 | #' @param L spatial lattice extent as a scalar variable (must not be a vector) 51 | #' @param mps pion mass as a scalar variable (must not be a vector) 52 | #' @param a0 scattering length at finite L 53 | #' @return returns a numeric value representing the finite size correction or 54 | #' in case of \code{fs.a0} the corrected value for a0. 55 | #' @author Carsten Urbach, \email{curbach@@gmx.de} 56 | #' @references For the original formula see Eq. (31) from hep-lat/0601033 57 | #' @examples 58 | #' fs.a0(a0=1., mps=0.123, L=24) 59 | #' @export 60 | fs.a0 <- function(a0, mps, L) { 61 | delta <- fs.qcotdelta(mps, L) 62 | return(1./(1./a0 + delta)) 63 | } 64 | 65 | ## this is the formula from 66 | ## arXiv:0909.3255 67 | ## directly for mpi*a0 68 | #' Finite Size Corrections to \eqn{q\cot\delta}{qcotdelta} for I=2 69 | #' \eqn{\pi\pi}{pipi} near threshold 70 | #' 71 | #' \code{fs.qcotdelta} computes the finite size corrections to 72 | #' \eqn{q\cot\delta}{qcotdelta} while \code{fs.mpia0} computes the 73 | #' corresponding finite size corrections to \eqn{M_\pi a_0}{Mpi a0} directly 74 | #' using the Gasser Leutwyler result from \eqn{M_\pi}{Mpi}. 75 | #' 76 | #' 77 | #' @param L spatial lattice extent as a scalar variable (must not be a vector) 78 | #' @param mps pion mass as a scalar variable (must not be a vector) 79 | #' @param fps pion decay constant as a scalar variable (must not be a vector) 80 | #' @return returns a numeric value representing the finite size correction or 81 | #' in case of \code{fs.a0} the corrected value for a0. 82 | #' @author Carsten Urbach, \email{curbach@@gmx.de} 83 | #' @references For the original formula see Eq. (31) from hep-lat/0601033 84 | #' @examples 85 | #' fs.mpia0(mps=0.123, fps=0.2, L=24) 86 | #' @export 87 | fs.mpia0 <- function(mps, fps, L) { 88 | 89 | fn <- function(n, cn, mpsL) { 90 | cn*exp(-n*mpsL)/sqrt(n*mpsL)*(1-17/(8*n*mpsL)) 91 | } 92 | cn <- c(6, 12, 8, 6, 24, 24, 0, 12) 93 | n <- c(1, sqrt(2), sqrt(3), 2, sqrt(5), sqrt(6), sqrt(7), sqrt(8)) 94 | S <- sum(fn(n, cn, mpsL=mps*L)) 95 | 96 | return(mps^4/fps^4/2^(13/2)/pi^(5/2)*S) 97 | } 98 | 99 | -------------------------------------------------------------------------------- /R/jackknifeafterboot.R: -------------------------------------------------------------------------------- 1 | jab <- function(t, t0, starts, m=1, fn=sd) { 2 | find.duplicates <- function(xstar, x) { 3 | duplicated(c(xstar, x))[(length(x) + 1):(2 * length(x))] 4 | } 5 | 6 | jack.boot <- function(indices, xstar, f) { 7 | if(is.null(dim(xstar))) apply(xstar[!indices], MARGIN=2L, FUN=f) 8 | else apply(X=xstar[!indices, ], MARGIN=2L, FUN=f) 9 | } 10 | 11 | ## total number of blocks 12 | N <- ncol(starts) 13 | ## number of blocks of blocks 14 | M <- N - m + 1 15 | duplicates <- t(apply(X=starts, MARGIN=1L, FUN=find.duplicates, x=c(1:N))) 16 | if(m > 1) { 17 | for(i in c(1:M)) { 18 | duplicates[,i] <- apply(duplicates[,c(i:(i+m-1))], MARGIN=1L, FUN=any) 19 | } 20 | duplicates <- duplicates[,c(1:M)] 21 | } 22 | 23 | jack.boot.values <- apply(X=duplicates, MARGIN=2L, FUN=jack.boot, xstar=t, f=fn) 24 | phitilde <- (N*t0 - (N-m)*jack.boot.values)/m - t0 25 | 26 | jack.boot.se <- sqrt(m/(N-m)/M * 27 | apply(X=phitilde, MARGIN=1L, FUN=function(x) {sum(x^2)}) 28 | ) 29 | return(jack.boot.se) 30 | } 31 | 32 | #' jab.cf 33 | #' 34 | #' apply jackknife after bootstrap to an cf object 35 | #' and compute errors accordingly 36 | #' 37 | #' @param cf object of type \link{cf} 38 | #' @param m integer. block length 39 | #' 40 | #' @return 41 | #' Returns an object of class `cf`, see \link{cf}, with 42 | #' Jackknife samples added accordingly. 43 | #' 44 | #' @export 45 | jab.cf <- function(cf, m = 1) { 46 | stopifnot(inherits(cf, 'cf')) 47 | stopifnot(inherits(cf, 'cf_boot')) 48 | stopifnot(cf$cf.tsboot$sim == "fixed") 49 | stopifnot(cf$resampling_method == 'bootstrap') 50 | 51 | old_seed <- swap_seed(cf$seed) 52 | ## the resampling block indices 53 | cf$blockind <- hadron:::boot_ts_array(n=cf$cf.tsboot$n, n.sim=cf$cf.tsboot$n.sim, 54 | R=cf$boot.R, l=cf$boot.l, sim=cf$sim, endcorr=cf$cf.tsboot$endcorr) 55 | restore_seed(old_seed) 56 | 57 | cf$jack.boot.se <- jab(t=cf$cf.tsboot$t, t0=cf$tsboot.se, starts=cf$blockind$starts, m=m, fn=sd) 58 | if( has_icf(cf) ){ 59 | # no randomness here so no seed setting required 60 | cf$ijack.boot.se <- jab(t=cf$icf.tsboot$t, t0=cf$itsboot.se, starts=cf$blockind$starts, m=m, fn=sd) 61 | } 62 | 63 | return(invisible(cf)) 64 | } 65 | 66 | #' jab.cf.derived 67 | #' 68 | #' apply jackknife after bootstrap to an derived cf object 69 | #' and compute errors accordingly 70 | #' 71 | #' @param cf object of type \link{cf} 72 | #' @param m integer. block length 73 | #' 74 | #' @return 75 | #' Returns a numeric vector with the jackknife estimates of 76 | #' standard error. 77 | #' 78 | #' @export 79 | jab.cf.derived <- function(cf, m=1) { 80 | if(cf$cf$cf.tsboot$sim != "fixed") { 81 | stop("JAB only implemented for 'sim=fixed' at the moment") 82 | } 83 | 84 | if(is.null(cf$cf$blockind)) { 85 | old_seed <- swap_seed(cf$seed) 86 | cf$cf$blockind <- hadron:::boot_ts_array(n=cf$cf$cf.tsboot$n, n.sim=cf$cf$cf.tsboot$n.sim, 87 | R=cf$cf$boot.R, l=cf$cf$boot.l, sim=cf$cf$sim, endcorr=cf$cf$cf.tsboot$endcorr) 88 | restore_seed(old_seed) 89 | } 90 | jack.boot.se <- jab(t=cf$t[,c(1:length(cf$se))], t0=cf$se, starts=cf$cf$blockind$starts, m=m, fn=sd) 91 | 92 | 93 | return(jack.boot.se) 94 | } 95 | 96 | jab.matrixfit <- function(cf, m=1) { 97 | if(!any(class(cf) == "matrixfit")) { 98 | stop("bootstrap.cf requires an object of class 'matrixfit' as input! Aborting!\n") 99 | } 100 | cf$jack.boot.se <- jab.cf.derived(cf=cf, m=m) 101 | return(invisible(cf)) 102 | } 103 | 104 | 105 | jab.effectivemass <- function(cf, m=1) { 106 | if(!any(class(cf) == "effectivemass")) { 107 | stop("bootstrap.cf requires an object of class 'matrixfit' as input! Aborting!\n") 108 | } 109 | cf$jack.boot.se <- jab.cf.derived(cf=cf, m=m) 110 | return(invisible(cf)) 111 | } 112 | 113 | jab.effectivemassfit <- function(cf, m=1) { 114 | if(!any(class(cf) == "effectivemassfit")) { 115 | stop("bootstrap.cf requires an object of class 'matrixfit' as input! Aborting!\n") 116 | } 117 | cf$jack.boot.se <- jab.cf.derived(cf=cf, m=m) 118 | return(invisible(cf)) 119 | } 120 | -------------------------------------------------------------------------------- /R/bootstrapnumber.R: -------------------------------------------------------------------------------- 1 | meanindexed <- function(data, indexvector) { 2 | return(invisible(mean(data[indexvector]))) 3 | } 4 | 5 | sd.index <- function(data, indexvector) { 6 | return(invisible(sd(data[indexvector]))) 7 | } 8 | 9 | 10 | 11 | #' Performs a Bootstrap with Blocking Analysis of a Timeseries 12 | #' 13 | #' Performs a Bootstrap with Blocking Analysis of a Timeseries 14 | #' 15 | #' the routine will compute the error, the error of the error and the 16 | #' integrated autocorrelation time for different block size using a bootstrap 17 | #' analysis. The blocksize is systematically increased starting from \code{1} 18 | #' until \code{(length(data)-skip)/blocksize < 20}. Note that only data is kept 19 | #' in exact multiples of the block length. 20 | #' 21 | #' @param data a numerical vector containing the time series 22 | #' @param skip integer value providing the warm up phase length. 23 | #' @param boot.R number of bootstrap samples. See also \link[boot]{boot}, and 24 | #' \link[boot]{tsboot}. 25 | #' @param boot.l block length for blocked bootstrap. 26 | #' @param tsboot.sim the \code{sim} parameter of \link[boot]{tsboot}. 27 | #' @param pl logical, indicating whether or not to plot the result. 28 | #' @return returns a data frame containing the mean value, the error 29 | #' approximation, the estimate of the error of the error, the value of tau int 30 | #' and the bias for all block sizes. 31 | #' @author Carsten Urbach, \email{carsten.urbach@@liverpool.ac.uk} 32 | #' @seealso for an alternative way to analyse such time series see 33 | #' \code{\link{uwerr}} and \code{\link{computeacf}} 34 | #' @keywords ts 35 | #' @examples 36 | #' 37 | #' data(plaq.sample) 38 | #' plaq.boot <- bootstrap.analysis(plaq.sample, pl=TRUE) 39 | #' 40 | #' @export bootstrap.analysis 41 | bootstrap.analysis <- function(data, skip=0, boot.R=100, 42 | tsboot.sim="geom", pl=FALSE, boot.l=2) { 43 | data <- data[skip:length(data)] 44 | data.mean = mean(data) 45 | error.naive = sd(data)/sqrt(length(data)) 46 | 47 | message("mean value = ", data.mean, "\n") 48 | message("naive error = ", error.naive, "\n") 49 | 50 | data.boot <- boot::boot(data=data, statistic=meanindexed, R=boot.R, stype="i") 51 | data.boot.ci <- boot::boot.ci(data.boot, type = c("norm", "basic", "perc")) 52 | 53 | message(" mean -err +err stderr bias\n") 54 | message("bootstrap = ", data.boot$t0[1], "(", (data.boot.ci$normal[1,2]-data.boot$t0[1])/1.96 55 | , ",", -(data.boot$t0[1]-data.boot.ci$normal[1,3])/1.96, ")", sd(data.boot$t[,1]), 56 | mean(data.boot$t[,1])-data.boot$t0[1],"\n") 57 | Blocksize <- numeric() 58 | Mean <- numeric() 59 | Error <- numeric() 60 | DError <- numeric() 61 | Tauint <- numeric() 62 | Bias <- numeric() 63 | Blocksize[1] <- 1 64 | Mean[1] <- data.boot$t0[1] 65 | Error[1] <- sd(data.boot$t[,1]) 66 | DError[1] <- 0. 67 | Tauint[1] <- 0. 68 | Bias[1] <- 0. 69 | 70 | message("blocking analysis:\n") 71 | message("\t\t\t mean \t stderr \t dstderr\t tau_int\t bias\n") 72 | j <- 1 73 | while((length(data))/boot.l > 20) { 74 | ndata <- block.ts(data, l=boot.l) 75 | j <- j+1 76 | data.tsboot <- boot::boot(ndata, statistic=meanindexed, R=boot.R) 77 | ## use the same seed ... 78 | set.seed(data.tsboot$seed) 79 | data.sdboot <- boot::boot(ndata, statistic=sd.index, R=boot.R) 80 | ##data.tsboot.ci <- boot.ci(data.tsboot, type = c("norm", "basic", "perc")) 81 | Blocksize[j] <- boot.l 82 | Mean[j] <- data.tsboot$t0[1] 83 | Error[j] <- sd(data.tsboot$t[,1]) 84 | DError[j] <- sd(data.sdboot$t[,1])/sqrt(length(ndata)) 85 | Tauint[j] <- sd(data.tsboot$t[,1])^2/error.naive^2/2 86 | Bias[j] <- data.tsboot$t0[1] - mean(data.tsboot$t[,1]) 87 | 88 | message("blocklength =", boot.l, "\t", Mean[j], "\t", Error[j], "\t", 89 | DError[j], "\t", Error[j]^2/error.naive^2/2, "\t", Bias[j], "\n") 90 | if(boot.l < 32) { 91 | boot.l <- boot.l*2 92 | } 93 | else { 94 | boot.l <- boot.l+20 95 | } 96 | } 97 | df <- data.frame(Blocksize=Blocksize, Mean=Mean, Error=Error, DError=DError, Tauint=Tauint, Bias=Bias) 98 | if(pl) { 99 | plot(data.boot) 100 | new_window_if_appropriate() 101 | plotwitherror(df$Blocksize, df$Error, df$DError, xlab="l", ylab="Error") 102 | } 103 | return(invisible(df)) 104 | } 105 | -------------------------------------------------------------------------------- /vignettes/hankel.bib: -------------------------------------------------------------------------------- 1 | @article{HASAN1997218, 2 | title = "Hankel Matrices of Finite Rank with Applications to Signal Processing and Polynomials", 3 | journal = "Journal of Mathematical Analysis and Applications", 4 | volume = "208", 5 | number = "1", 6 | pages = "218 - 242", 7 | year = "1997", 8 | issn = "0022-247X", 9 | doi = "https://doi.org/10.1006/jmaa.1997.5319", 10 | url = "http://www.sciencedirect.com/science/article/pii/S0022247X97953191", 11 | author = "Mohammed A Hasan and Ali A Hasan", 12 | abstract = "It is shown that certain sequences of Hankel matrices of finite rank obtained from a given sequence of complex numbers and powers of companion matrices are closely related. This relation is established by investigating the algebraic properties of combinations of polynomial multiples of powers of complex numbers. Among many applications, these properties are used to construct polynomials with zeros being a function of the zeros of given polynomials. For example, Hankel matrices of finite rank are used to develop a method for computing the least common multiple of a finite number of polynomials without factoring them, or computing a polynomial whose zeros are the product of the zeros of two polynomials. A method for computing a factor of the characteristic polynomial of a given matrix is also presented and is established by forming certain types of Hankel matrices whose entries are generated from linear combinations of powers of zeros of its characteristic polynomial. Applications of these ideas to signal processing and computational linear algebra are also given." 13 | } 14 | 15 | @Article{Sharma2018, 16 | author="Sharma, Rishi Raj and Pachori, Ram Bilas", 17 | title="Eigenvalue Decomposition of Hankel Matrix-Based Time-Frequency Representation for Complex Signals", 18 | journal="Circuits, Systems, and Signal Processing", 19 | year="2018", 20 | month="Aug", 21 | day="01", 22 | volume="37", 23 | number="8", 24 | pages="3313--3329", 25 | abstract="The analysis of non-stationary signals using time-frequency representation (TFR) presents simultaneous information in time and frequency domain. Most of TFR methods are developed for real-valued signals. In several fields of science and technology, the study of unique information presented in the complex form of signals is required. Therefore, an eigenvalue decomposition of Hankel matrix-based TFR method, which is a data-driven technique, has been extended for the analysis of complex-valued signals. In this method, the positive and negative frequency components of complex signals are separately decomposed using recently developed eigenvalue decomposition of Hankel matrix-based method. Further, the Hilbert transform is applied on decomposed components to obtain TFR for both positive and negative frequency ranges. The proposed method for obtaining TFR is compared with the existing methods. Results for synthetic and natural complex signals provide support to the proposed method to perform better than compared methods.", 26 | issn="1531-5878", 27 | doi="10.1007/s00034-018-0834-4", 28 | url="https://doi.org/10.1007/s00034-018-0834-4" 29 | } 30 | @article{prony:1795, 31 | author="G. R. de Prony", 32 | journal="Journal de l’cole Polytechnique", 33 | volume="1", 34 | number="22", 35 | pages="24-76", 36 | year="1795" 37 | } 38 | @inproceedings{Lin:2007iq, 39 | author = "Lin, Huey-Wen and Cohen, Saul D.", 40 | title = "{Lattice QCD beyond ground states}", 41 | booktitle = "{4th International Workshop on Numerical Analysis and 42 | Lattice QCD New Haven, CT, May 1-3, 2007}", 43 | url = "http://www1.jlab.org/Ul/publications/view_pub.cfm?pub_id=7593", 44 | year = "2007", 45 | eprint = "0709.1902", 46 | archivePrefix = "arXiv", 47 | primaryClass = "hep-lat", 48 | reportNumber = "JLAB-THY-07-720", 49 | SLACcitation = "%%CITATION = ARXIV:0709.1902;%%" 50 | } 51 | 52 | @article{gardner:1959, 53 | author = {Gardner,Donald G. and Gardner,Jeanne C. and Laush,George and Meinke,W. Wayne }, 54 | title = {Method for the Analysis of Multicomponent Exponential Decay Curves}, 55 | journal = {The Journal of Chemical Physics}, 56 | volume = {31}, 57 | number = {4}, 58 | pages = {978-986}, 59 | year = {1959}, 60 | doi = {10.1063/1.1730560}, 61 | 62 | URL = { 63 | https://doi.org/10.1063/1.1730560 64 | 65 | }, 66 | eprint = { 67 | https://doi.org/10.1063/1.1730560 68 | 69 | } 70 | 71 | } 72 | --------------------------------------------------------------------------------