From 3d4244f1fd6db05f565c88c74033d17ff6e2111c Mon Sep 17 00:00:00 2001 From: Taha Ahmed Date: Wed, 21 Sep 2011 13:41:08 +0200 Subject: [PATCH] Added XRD peak wrapper functions (as done previously for XRF and Raman). Also put the short R-data loading function I wrote into the common directory. --- XRD-TF/pdf2df.R | 6 +-- XRD-TF/xrdpk.R | 92 +++++++++++++++++++++++++++++++++++++ XRD-TF/xrdpkWrapper.R | 63 +++++++++++++++++++++++++ common/LoadRData2Variable.R | 6 +++ 4 files changed, 164 insertions(+), 3 deletions(-) create mode 100644 XRD-TF/xrdpk.R create mode 100644 XRD-TF/xrdpkWrapper.R create mode 100644 common/LoadRData2Variable.R diff --git a/XRD-TF/pdf2df.R b/XRD-TF/pdf2df.R index 49189f5..aaf4f9d 100644 --- a/XRD-TF/pdf2df.R +++ b/XRD-TF/pdf2df.R @@ -19,7 +19,6 @@ pdf2df <- function(pdffile) { # attr: This function sets the following attributes: # ApplicationName, # ApplicationVersion, - # pdfNumber, # chemicalformula, # empiricalformula, # wavelength @@ -55,13 +54,14 @@ pdf2df <- function(pdffile) { "$}", sep = "", collapse = ""), intensity = as.numeric(gsub(rmchar, "", xmlValue(pdf[["graphs"]][["stick_series"]][[i]][["intensity"]]))), int.TeX = paste("{", xmlValue(pdf[["graphs"]][["stick_series"]][[i]][["intensity"]]), "}", sep = ""), - pdfNumber = xmlValue(pdf[["pdf_data"]][["pdf_number"]]) + pdfNumber = xmlValue(pdf[["pdf_data"]][["pdf_number"]]), + formula = gsub("[ ]", "", xmlValue(pdf[["pdf_data"]][["empirical_formula"]])) )) } # attr(angles, "ApplicationName") <- xmlAttrs(pdf)[[1]] attr(angles, "ApplicationVersion") <- xmlAttrs(pdf)[[2]] - attr(angles, "pdfNumber") <- xmlValue(pdf[["pdf_data"]][["pdf_number"]]) + #attr(angles, "pdfNumber") <- xmlValue(pdf[["pdf_data"]][["pdf_number"]]) attr(angles, "chemicalformula") <- gsub("[ ]", "", xmlValue(pdf[["pdf_data"]][["chemical_formula"]])) attr(angles, "empiricalformula") <- gsub("[ ]", "", xmlValue(pdf[["pdf_data"]][["empirical_formula"]])) attr(angles, "wavelength") <- as.numeric(xmlValue(pdf[["graphs"]][["wave_length"]])) diff --git a/XRD-TF/xrdpk.R b/XRD-TF/xrdpk.R new file mode 100644 index 0000000..7d1f2f3 --- /dev/null +++ b/XRD-TF/xrdpk.R @@ -0,0 +1,92 @@ +xrdpk <- + function(xrd.exp, kerpk = 1, fitmaxiter = 50, gam = 1.0, scl.factor = 1.2, maxwdth=5.0) { + + xrd.base <- baselinefit(xrd.exp, tau=2.5, gam=gam, scl.factor=scl.factor, maxwdth=maxwdth) + + # This loop deals with the output from baselinefit() + # It makes a "melted" dataframe in long form for each + # separated peak for some baseline parameters + xrd.pks <- data.frame() + xrd.pks.basl <- data.frame() + xrd.pks.pmg <- data.frame() + xrd.pks.spl <- data.frame() + peaks <- 1:length(xrd.base$npks) + for (s in peaks) { + # recorded data in long form by separated peak + xrd.pks <- rbind(xrd.pks, # column names assigned after loop + data.frame(peak = factor(peaks[s]), + kernel = NA, + xrd.exp[xrd.base$indlsep[s]:xrd.base$indrsep[s], ])) + # the calculated baseline in long form by separated peak + xrd.pks.basl <- rbind(xrd.pks.basl, + data.frame(peak = factor(peaks[s]), + kernel = NA, + x = xrd.exp[xrd.base$indlsep[s]:xrd.base$indrsep[s], ], + y = xrd.base$baseline$basisl[xrd.base$indlsep[s]:xrd.base$indrsep[s]])) + # the taut string estimation in long form by separated peak + xrd.pks.pmg <- rbind(xrd.pks.pmg, + data.frame(peak = factor(peaks[s]), + kernel = NA, + x = xrd.exp[xrd.base$indlsep[s]:xrd.base$indrsep[s], ], + y = xrd.base$pmg$fn[xrd.base$indlsep[s]:xrd.base$indrsep[s]])) + # the weighted smoothed spline in long form by separated peak + xrd.pks.spl <- rbind(xrd.pks.spl, + data.frame(peak = factor(peaks[s]), + kernel = NA, + x = xrd.exp[xrd.base$indlsep[s]:xrd.base$indrsep[s], ], + y = xrd.base$spl$reg[xrd.base$indlsep[s]:xrd.base$indrsep[s]])) + } + # Column names assigned to d.pks + names(xrd.pks) <- c("peak", "kernel", "x", "y") + + + # This loop calls pkdecompint() on each peak separately + # It makes a "melted" dataframe in long form for: + xrd.fit <- list() # holds pkdecompint output + xrd.fit.fitpk <- data.frame() # contains fitting curves + xrd.fit.parpk <- data.frame() # physical parameters by peak and kernel + xrd.nobasl <- data.frame() # data with baseline removed + peaks <- 1:length(xrd.base$npks) + for (s in peaks) { + ######## PKDECOMPINT ######## + if (length(kerpk) > 1) { + # set number of kernels per peak manually + xrd.fit[[s]] <- pkdecompint(xrd.base, intnum = s, + k = kerpk[s], maxiter = fitmaxiter) + } else { + # use number of kernels determined by baselinefit() + xrd.fit[[s]] <- pkdecompint(xrd.base, intnum = s, + k = xrd.base$npks[s], maxiter = fitmaxiter) + } + # Setup the dataframe that makes up the peak table + for (kernel in 1:xrd.fit[[s]]$num.ker) { + xrd.fit.parpk <- rbind(xrd.fit.parpk, + data.frame(peak = factor(xrd.fit[[s]]$intnr), + kernel = factor(kernel), + x = xrd.fit[[s]]$parpks[kernel, "loc"], + height = xrd.fit[[s]]$parpks[kernel, "height"], + area = xrd.fit[[s]]$parpks[kernel, "intens"], + fwhm = xrd.fit[[s]]$parpks[kernel, "FWHM"], + m = xrd.fit[[s]]$parpks[kernel, "m"], + accept = xrd.fit[[s]]$accept)) + xrd.fit.fitpk <- rbind(xrd.fit.fitpk, + data.frame(peak = factor(peaks[s]), + kernel = factor(kernel), + x = xrd.fit[[s]]$x, + y = xrd.fit[[s]]$fitpk[kernel, ])) + } + xrd.nobasl <- rbind(xrd.nobasl, + data.frame(peak = factor(peaks[s]), + x = xrd.fit[[s]]$x, + y = xrd.fit[[s]]$y)) + } + + + + return(list(xrd.base = xrd.base, + xrd.peaks = xrd.pks, + xrd.fit.parpk = xrd.fit.parpk, + xrd.fit.fitpk = xrd.fit.fitpk, + xrd.nobasl = xrd.nobasl)) + +} diff --git a/XRD-TF/xrdpkWrapper.R b/XRD-TF/xrdpkWrapper.R new file mode 100644 index 0000000..c6fb0f6 --- /dev/null +++ b/XRD-TF/xrdpkWrapper.R @@ -0,0 +1,63 @@ +xrdpkWrapper <- + function(data.exp, run, override = FALSE, + kerpk = 1, fitmaxiter = 50, gam = 1.0, scl.factor = 1.2, maxwdth=5.0) { + + print("... Started xrdpkWrapper") + + # check if xrdpk has already completed successfully for the current job + current.dirname <- getwd() + print(current.dirname) + current.filename <- "xrd-peak-data.rda" + xrddatafile <- paste(current.dirname, current.filename, sep = "/") + + + if (file.exists(xrddatafile) && !override) { + print("... Started if-clause 1") + + # File already exists + # return the data using load() or data() + + load(file = xrddatafile) + + if (run > length(xrdres)) { + + print("... Started if-clause 1:1") + + # then it does not really exist + xrdres[[run]] <- xrdpk(data.exp, + kerpk = kerpk, + fitmaxiter = fitmaxiter, + gam = gam, + scl.factor = scl.factor, + maxwdth = maxwdth) + save(xrdres, file = xrddatafile) + + print("... Ended if-clause 1:1") + } + + print("... Ended if-clause 1") + + return(xrdres) + } else { + + print("... Started else-clause 1") + + if (!exists("xrdres")) { + xrdres <- list() + print("... xrdres list created") + } + + # Need to call xrdpk() and save its results to file as above + xrdres[[run]] <- xrdpk(data.exp, + kerpk = kerpk, + fitmaxiter = fitmaxiter, + gam = gam, + scl.factor = scl.factor, + maxwdth = maxwdth) + save(xrdres, file = xrddatafile) + + print("... Ended else-clause 1") + + return(xrdres) + } +} diff --git a/common/LoadRData2Variable.R b/common/LoadRData2Variable.R new file mode 100644 index 0000000..ee2795e --- /dev/null +++ b/common/LoadRData2Variable.R @@ -0,0 +1,6 @@ +# Function loads R-data file into a variable instead of into the workspace +# Works well when the R-data file contains only ONE variable +# NOT TESTED for when the R-data file contains many variables +LoadRData2Variable <- function(FullPathToRData) { + return(eval(parse(text = load(FullPathToRData)))) +} \ No newline at end of file