Nothing
#' @title Import BUCHI NIRCal files
#' @description
#'
#' \ifelse{html}{\out{<a href='https://www.tidyverse.org/lifecycle/#maturing'><img src='figures/lifecycle-maturing.svg' alt='Maturing lifecycle'></a>}}{\strong{Maturing}}
#'
#' This function imports .nir files generated by BUCHI NIRCal software.
#' @usage
#' read_nircal(file, response = TRUE, spectra = TRUE,
#' metadata = TRUE, progress = TRUE, verbose = TRUE)
#' @param file the name of the NIRCal (.nir) file which the data are to be read
#' from. For URLs a temporary file is first downloaded and is then read.
#' @param response a logical indicating if the data of the response variables
#' must be returned (default is `TRUE`).
#' @param spectra a logical indicating if the spectral data must be returned
#' (default is `TRUE`).
#' @param metadata a logical indicating if the metadada must be returned
#' (default is `TRUE`).
#' @param progress a logical indicating if a progress bar must be printed
#' (default is `TRUE`).
#' @param verbose a logical indicating if the number of spectra and response
#' variables (an also the ID's of the spectra without gain and/or temperature
#' information) must be printed (default is `TRUE`).
#' @return a data.frame containing the metadata, response variables (if
#' `response = TRUE`) and spectra (if `spectra = TRUE`, embedded in the
#' `data.frame` as a matrix named `...$spc`).
#' @details
#' The extension of the BUCHI NIRCal files is .nir. These files are used to
#' store spectra generated by BUCHI N-500 and BUCHI NIRMaster FT-NIR sensors.
#' See
#' \href{https://assets.buchi.com/image/upload/v1605790933/pdf/Technical-Datasheet/TDS_11593569_NIRCal.pdf}{NIRCal technical data sheet.}
#' @author \href{https://orcid.org/0000-0002-5369-5120}{Leonardo Ramirez-Lopez}
#' @importFrom utils download.file
#' @export
## 23.03.2018 (leo): Since the scan function was crashing with some files, it
## was removed and replaced by readBin.
## Comment and Description fields are now read and added to
## the resulting data.frame
## 17.05.2018 (leo): A bug on comment_s was fixed. Characters with special
## accent were not recognized when [0-9 A-Z a-z 0-9A-Za-z [:punct:]]
## was used, this was fixed with [ [:punct:][:alnum:]]
## 17.05.2018 (leo): A new sanity check for repeated property names has been added.
## 04.07.2018 (leo): A bug on comment_f was fixed. Characters with special
## accent were not recognized when [0-9 A-Z a-z 0-9A-Za-z [:punct:]]
## was used, this was fixed with [ [:punct:][:alnum:]].
## The same prvious bug as for comment_s
## 16.07.2018 (leo): Now the function also reads the sample temperature
## (is only available for transmission measurements, i.e.
## measuremnt cell liquids)
## 08.08.2018 (leo): Variables identified as wavelengths are now correctly
## identified as wavenumbers
## 08.08.2018 (leo): Heaviliy re-coded for computational eficiency
## 08.08.2018 (leo): It now allows parallel computing by using the foreach
## package
## 08.08.2018 (leo): A new argument was added: preschedule
## 17.09.2018 (leo): A bug when repeated property names was corrected
## 19.09.2018 (leo): A new argument was added (metadata = TRUE). This is a
## workaround to avoid errors in reading metadata of files
## which are
## created in NIRCal which are the result of NIRCal computations
## and do not store metadata of the original measurements
## 10.01.2019 (leo): Function was crashing when property names contained special
## characters
## 23.01.2019 (leo): The collection of the description filed was failing since
## not all nircal files have the description right on top of
## the sample GUID.
## This is now corrected by extracting the description info
## from anoher place in the file
## 11.02.2019 (leo): The code was releasing the following warning (now at at
## ac <- unlist(strsplit(x = ab[1],
## split = "\n", useBytes = TRUE))); Warning in
## strsplit(ab[1], "\n") :
## input string 1 is invalid in this locale. Now the function
## uses the argument useBytes = TRUE to avoid this issue.
## If TRUE the matching is done byte-by-byte
## rather than character-by-character, and inputs with marked
## encodings are not converted. Now useBytes = TRUE is used
## whenever the strsplit() is used.
## 20.02.2019 (leo): The metadata was collected based on the position of the
## InstrumentType info (assuming it was NIRFlex). Now this is
## not asumed as it is possible that this information is
## missing or that a different sensor is registered in the
## file. Now the only reference is the name of the software
## used to create the file (which is always nircal)
## 20.02.2019 (leo): The device name is now an output (e.g. NIRFlex)
## 13.06.2019 (leo): Property names with a slash character "/" (e.g. TMA/ABVT)
## were causing the function to crash. This was fixed
## Any "/" in a property name will be replaced with "_"
## 13.03.2020 (leo): using now connections in conjunction with raw vectors
## (hexView no longer used). Code for reading responses,
## spectra and metadata has been vectorized (significantly).
## Function compartmentalization.
## 13.03.2020 (leo): bug fix. from 1:n[idxdescription] to (1:n)[idxdescription]
## 13.05.2020 (leo): reads from URLs
## 25.01.2022 (leo): bug fix in get_nircal_description(): it reads the proper
## number of recods based on n
read_nircal <- function(file,
response = TRUE,
spectra = TRUE,
metadata = TRUE,
progress = TRUE,
verbose = TRUE) {
con <- file(file, "rb")
if ("url" %in% class(con)) {
close(con)
tmp <- tempfile(pattern = "", fileext = ".nir")
download.file(
url = file, destfile = tmp, method = "auto", quiet = FALSE, mode = "wb",
cacheOK = TRUE,
extra = getOption("download.file.extra"),
headers = NULL
)
message("File at: '", tmp, "'\n")
file <- tmp
con <- file(file, "rb")
} else {
if (!file.exists(file)) {
stop("File does not exists!")
}
}
seek(con, where = 1, origin = "start")
nircalraw <- readBin(con,
what = "raw",
n = file.info(file)$size
)
first_lines <- readLines(con = file, 1:2)
if (length(first_lines) >= 1) {
isnircal <- grepRaw("NIRCAL Project File", first_lines, all = TRUE)
} else {
isnircal <- NULL
}
if (length(isnircal) == 0) {
stop("Ups! This does not look like a BUCHI NIRCal file")
}
rawcoords <- get_nircal_indices(x = nircalraw)
ids <- get_nircal_ids(connection = con, from = rawcoords$values_s[5], to = rawcoords$values_s2)
nd <- length(ids)
nms <- c(
"ID", "GUID", "Scans", "resolution", "nWavenumbers", "WavenumberSteps", "WavenumberStart",
"Device", "Software Version", "Created", "Modified", "Creator", "Creator login", "Modified by",
"Modifier login", "Instrument serial", "Measurement cell", "Option serial", "Gain factor",
"Gain", "Instrument temperature", "Sample temperature", "Comment", "Description"
)
dextracted <- matrix(NA, length(ids), length(nms))
dextracted <- data.frame(dextracted)
colnames(dextracted) <- nms
dextracted$ID <- ids
if (response) {
responses <- get_nircal_response(x = nircalraw, n = nd)
dextracted <- cbind(dextracted, responses$properties)
nms <- colnames(dextracted)
if (!is.null(responses$warning)) {
warning(responses$warning)
}
}
readmessage <- paste(
"File contains", nd, ifelse(nd == 1, "spectrum", "spectra"),
ifelse(response,
ifelse(length(responses$property_names) == 1 & "<<undef>>" %in% responses$property_names, "and one unnamed response variable",
paste("and", length(responses$property_names), "response variables")
), ""
)
)
readmessage <- paste(readmessage, "\n", sep = "")
if (verbose) {
cat(readmessage)
}
if (progress) {
pb <- txtProgressBar(style = 1)
g1 <- 0.75
g2 <- 0.10
g3 <- 0.07
}
## verify that what it was read coincides with the number of samples specified in the file
if (rawcoords$nsamples != nd) {
stop("number of samples do not match the number of IDs")
}
if (progress) {
setTxtProgressBar(pb, g1)
}
if (!is.null(rawcoords$comment_s) | !is.null(rawcoords$comment_f)) {
.comment <- get_nircal_comments(
connection = con,
metanumbers = rawcoords$metanumbers,
begin_s = rawcoords$begin_s,
comment_s = rawcoords$comment_s,
comment_f = rawcoords$comment_f,
n = nd
)
description <- get_nircal_description(
x = nircalraw,
begin_s = rawcoords$begin_s,
spcinfo = rawcoords$spcinfo,
comment_s = rawcoords$comment_s,
comment_f = rawcoords$comment_f,
n = nd
)
} else {
warning("comments and description fields cointain unreadable data, these fields have been skipped")
.comment <- description <- rep(NA, nd)
}
dextracted$Comment <- as.character(.comment)
dextracted$Description <- as.character(description)
if (progress) {
setTxtProgressBar(pb, g1 + g2)
}
speclength <- get_nircal_lengthspc(
connection = con,
from = rawcoords$values_s[6],
to = rawcoords$values_s[7] - rawcoords$values_s[6]
)
n_s <- rawcoords$end_s - rawcoords$begin_s - 1
spctra_start <- rawcoords$begin_s[n_s == speclength * 8]
## it is here where each spectrum starts
spctra_start <- spctra_start[spctra_start > min(rawcoords$spcinfo)]
## -- Collect the spectra --
if (spectra) {
dspectra <- get_nircal_spectra(
x = nircalraw,
values_s = rawcoords$values_s,
spctra_start = spctra_start,
speclength = speclength,
n = nd
)
dextracted$spc <- dspectra
}
if (progress) {
setTxtProgressBar(pb, g1 + g2 + g3)
cmpl <- g1 + g2 + g3
stp <- (1 - cmpl) / nd
} else {
stp <- NULL
cmpl <- NULL
}
if (metadata) {
metda <- get_nircal_metadata(
connection = con,
n = nd,
spctra_start = spctra_start,
spcinfo = rawcoords$spcinfo,
progress = progress,
pb = pb,
progress.start = cmpl,
progress.steps = stp
)
dextracted[, colnames(metda)] <- metda
if (progress) {
# Close connection
close(con, type = "rb")
}
} else {
guididx <- unlist(lapply(rawcoords$spcinfo[1:nd],
FUN = function(x, l) x:(x + l),
l = 41
))
if (progress) {
setTxtProgressBar(pb, 1)
}
guids <- readChar(nircalraw[guididx], nchars = nd * (41 + 1))
guids <- strsplit(guids, "\n")[[1]]
guids <- gsub("[0-9]{2}/", "", guids)
dextracted$GUID <- guids
dextracted$nWavenumbers <- speclength
}
if (progress) {
close(pb)
}
numericp <- c(
"Scans",
"resolution",
"nWavenumbers",
"WavenumberSteps",
"WavenumberStart",
"Gain factor",
"Gain",
"Instrument temperature",
"Sample temperature"
)
dextracted[, numericp] <- as.numeric(unlist(dextracted[, numericp]))
dextracted$`Gain factor`[dextracted$`Gain factor` == 0] <- NA
dextracted$`Instrument temperature`[dextracted$`Instrument temperature` == 0] <- NA
dextracted$Device[dextracted$Device == ""] <- NA
dextracted$Device[dextracted$Device %in% c("0", "1", "-1")] <- NA
if (verbose) {
if (sum(is.na(dextracted$`Gain factor`)) > 0) {
if (nrow(dextracted) == 1) {
cat("Gain data is not available\n")
} else {
cat("Gain data is not available for one or more observations\n")
}
}
if (sum(is.na(dextracted$`Instrument temperature`)) > 0) {
if (nrow(dextracted) == 1) {
cat("Instrument temperature data is not available\n")
} else {
cat("Instrument temperature data is not available for one or more observations\n")
}
}
}
if (!sum(!is.na(dextracted$spc))) {
dextracted <- dextracted[, !colnames(dextracted) %in% "spc"]
}
return(dextracted)
}
#' @title get the positions of relevant data witihi the nircal file
#' @description internal
#' @keywords internal
get_nircal_indices <- function(x) {
beginchr <- "begin"
endchr <- "end"
begin_s <- grepRaw(paste("\n", beginchr, "\n", sep = ""), x, all = TRUE) + nchar(beginchr) + 2
end_s <- grepRaw(paste("\n", endchr, "\n", sep = ""), x, all = TRUE) + 1
values_s <- grepRaw("Values", x, all = TRUE)
values_s2 <- grepRaw("\n1[[:space:]]Values", x, all = TRUE)
values_s2 <- values_s2[1 + sum(!values_s2 > values_s[5])]
values_s3 <- grepRaw("[0-9]{1,}[[:space:]]Values", x, all = TRUE)[5]
spcinfo <- 1 + grepRaw("\n38\\/\\{", x, all = TRUE)[-1]
## The numbers in NIRCal files preceeding the files comment and description (e.g 11/ or 7/)
metanumbers <- grepRaw("[[0-9]]{0,}\\/Comment\n[[0-9]{0,}\\/Description", x, all = TRUE)[1]
lnss <- values_s[5] - values_s3
nss <- as.numeric(readBin(x[values_s3:(values_s3 + lnss - 1)], "character"))
srchc_s <- "[ [:punct:][:alnum:]]{0,}\n[ [:punct:][:alnum:]]{0,}\\/[ [:alnum:][:punct:]]{0,}\n38\\/\\{"
srchc_f <- "\n[ [:punct:][:alnum:]]{0,}\\/[ [:punct:][:alnum:]]{0,}\n38\\/\\{"
comment_s <- grepRaw(srchc_s, x, ignore.case = TRUE, all = TRUE)
comment_f <- grepRaw(srchc_f, x, ignore.case = TRUE, all = TRUE)
if (length(comment_s) < nss | length(comment_f) < nss) {
read_comments_description <- FALSE
comment_s <- comment_f <- NULL
}
return(list(
nsamples = nss,
begin_s = begin_s,
end_s = end_s,
values_s = values_s,
values_s2 = values_s2,
values_s3 = values_s3,
spcinfo = spcinfo,
metanumbers = metanumbers,
comment_s = comment_s,
comment_f = comment_f
))
}
get_nircal_ids <- function(connection, from, to) {
seek(connection, where = from, origin = "start")
ids <- readBin(
readBin(connection, what = "raw", n = to - from),
"character"
)
ids <- enc2utf8(ids)
ids <- strsplit(ids, "\n", useBytes = TRUE)[[1]]
# ids <- iconv(ids, to = "UTF-8", sub = NA)
ids2 <- ids[-c(1, length(ids))]
ids <- try(substr(x = ids2, start = regexpr("/", ids) + 1, stop = 100000))
if (inherits(ids, "try-error")) {
ids <- iconv(ids2, from = "Latin1", to = "UTF-8")
}
flush(connection)
return(ids)
}
#' @title get the comments of the spectra in the nircal file
#' @description internal
#' @keywords internal
get_nircal_comments <- function(connection, metanumbers, begin_s, comment_s, comment_f, n) {
if (length(comment_s) < n | length(comment_f) < n) {
warning("comments cannot be read")
comment <- rep(NA, n)
return(comment)
} else {
comment_s <- comment_s[1:n]
comment_f <- comment_f[1:n]
seek(connection,
where = metanumbers + begin_s[sum(metanumbers > begin_s) + 1],
origin = "start"
)
readb <- function(..i.., connection, comment_s, comment_f) {
seek(connection, where = comment_s[..i..], origin = "start")
i.comment <- readBin(
readBin(connection,
what = "raw",
n = comment_f[..i..] - comment_s[..i..]
),
"character"
)
# i.comment <- readChar(connection, nchars = comment_f[..i..] - comment_s[..i..])
i.comment
}
comment <- description <- rep(NA, n)
idxcomments <- (comment_f - comment_s) > 2
i.comment <- sapply(
X = (1:n)[idxcomments],
FUN = readb,
connection = connection,
comment_s = comment_s,
comment_f = comment_f
)
comment[idxcomments] <- i.comment
comment <- gsub("^[.]{0,}[0-9]{1,}\\/", "", comment)
flush(connection)
return(comment)
}
}
#' @title get the description of the spectra in the nircal file
#' @description internal
#' @keywords internal
get_nircal_description <- function(x, begin_s, spcinfo, comment_s, comment_f, n) {
if (length(comment_s) < n | length(comment_f) < n) {
warning("comments cannot be read")
description <- rep(NA, )
return(description)
} else {
comment_s <- comment_s[1:n]
comment_f <- comment_f[1:n]
## The numbers in NIRCal files preceeding the files comment and description (e.g 11/ or 7/)
metanumbers <- grepRaw("[[0-9]]{0,}\\/Comment\n[[0-9]{0,}\\/Description", x, all = TRUE)
if (length(metanumbers) > 2) {
metanumbers <- metanumbers[3]
} else {
metanumbers <- metanumbers[1]
}
metanumbersinfo <- readBin(x[metanumbers:(metanumbers + begin_s[sum(metanumbers > begin_s) + 1])], "character")
metanumbersinfo <- strsplit(metanumbersinfo, "\n", useBytes = TRUE)[[1]]
metadescription <- strsplit(metanumbersinfo[2], "Description", useBytes = TRUE)[[1]]
srchmtd <- paste("[0-9]{1,}/1/cm\n", metadescription, "[A-Z a-z]{1,}\n", sep = "")
srchmtd2 <- "[0-9]{1,}/1/cm\n[0-9]{1,}/[A-Z a-z]{1,}\n"
i_description <- grepRaw(srchmtd,
value = TRUE,
x,
all = TRUE
)
if (length(i_description) < n) {
i_description <- grepRaw(srchmtd2,
value = TRUE,
x,
all = TRUE
)
}
if (length(i_description) < n) {
warning("description field could not be read")
description <- rep(NA, n)
} else {
i_description <- i_description[1:n]
if (length(i_description) > 0) {
i_description <- sapply(X = i_description, FUN = readBin, what = "character")
i_description <- strsplit(i_description, paste("[0-9]{1,}/1/cm\n", metadescription, "|\n", sep = ""), useBytes = TRUE)
description <- sapply(X = i_description, FUN = function(x) x[[2]])
} else {
## This part might fail since not all nircal files have the description right on top of the sample GUID
readd <- function(..i.., rawf, comment_s, comment_f, spcinfo) {
rvec <- comment_s[..i..]:(comment_s[..i..] + spcinfo[..i..] - comment_f[..i..])
i_description <- readChar(rawf[rvec], spcinfo[..i..] - comment_f[..i..] + 1)
i_description
}
idxdescription <- (spcinfo[1:n] - comment_f) > 2
i_description <- sapply(
X = (1:n)[idxdescription],
FUN = readd,
rawf = x,
comment_s = comment_s,
comment_f = comment_f,
spcinfo = spcinfo
)
i_description <- iconv(i_description, from = "ASCII", to = "UTF-8", sub = "byte")
i_description
description <- rep(NA, n)
description[idxdescription] <- i_description
description[description == ""] <- NA
description <- gsub("[ [:punct:][:alnum:]]{0,}\n[ [:punct:][:alnum:]]{0,}\\/", "", description)
description <- gsub("[.]$", "", description)
}
}
return(description)
}
}
#' @title get the number of spectral variables in the nircaa file
#' @description internal
#' @keywords internal
get_nircal_lengthspc <- function(connection, from, to) {
seek(connection, where = from, origin = "start")
speclength <- readChar(connection, nchars = to)
speclength <- strsplit(speclength, "\n", useBytes = TRUE)[[1]]
speclength <- as.numeric(speclength[length(speclength)])
flush(connection)
return(speclength)
}
#' @title get the response variables in the nircal file
#' @description internal
#' @keywords internal
get_nircal_response <- function(x, n) {
## get the data of the response variables
property_info_start <- grepRaw(
"10/Properties\n18/Property Selection",
x,
all = TRUE
)[1]
property_info_end <- grepRaw("begin", x, offset = property_info_start, all = TRUE)
property_info_indcs <- property_info_start:(property_info_start + property_info_end[2] - property_info_start)
nproperties_c <- strsplit(readBin(x[property_info_indcs], what = "character"),
"\n",
useBytes = TRUE
)[[1]][5]
nproperties_n <- as.numeric(unlist(strsplit(nproperties_c, "Values", useBytes = TRUE)))
property_names_indcs <- grepRaw(nproperties_c,
x,
offset = property_info_start,
all = TRUE
)
property_names_indcs <- property_names_indcs[3]:(property_names_indcs[3] + property_info_end[3] - property_names_indcs[3])
property_names_char <- readBin(
x[property_names_indcs],
what = "character"
)
property_names_utf <- iconv(property_names_char, from = "ASCII", to = "UTF-8", sub = "byte")
property_names_utf <- strsplit(property_names_utf, "\n", useBytes = TRUE)[[1]][1 + c(1:nproperties_n)]
property_names_char <- strsplit(property_names_char, "\n", useBytes = TRUE)[[1]][1 + c(1:nproperties_n)]
# property_names_search <- sapply(
# property_names_char,
# FUN = function(x) strsplit(x, "[0-9]{0,}/")[[1]][[2]],
# USE.NAMES = FALSE
# )
property_names_search <- property_names_char
# property_names_search <- gsub(
# pattern = "[[:punct:]]",
# replacement = "[[:punct:]]",
# x = property_names_search
# )
# property_names_search <- gsub("[^ -~]", "[^ -~]", property_names_search)
# property_names_char <- gsub("[^ -~]", "[^ -~]", property_names_char)
property_names <- sapply(
property_names_utf,
FUN = function(x) strsplit(x, "[0-9]{0,}/")[[1]][[2]],
USE.NAMES = FALSE
)
proppositions <- grepRaw(paste(property_names_char, collapse = "\n"),
x,
fixed = FALSE,
all = TRUE
)[-1]
nval <- paste(length(property_names), "Values")
property_names_search <- paste(
c(
nval,
# paste("[0-9]{0,}\\/", property_names_search, sep = "", collapse = "\n"),
paste(property_names_search, sep = "", collapse = "\n"),
"[0-9]{0,}",
nval,
"begin"
),
collapse = "\n"
)
property_indices <- grepRaw(
property_names_search,
x,
all = TRUE
)
lengthproperty_indices <- length(
grepRaw(
property_names_search,
x,
all = FALSE,
value = TRUE
)
) + 1
if (sum(duplicated(property_names)) > 0) {
wrn <- c("Some property names are duplicated, please correct the names. Indices have been added to the repeated names")
dpn <- unique(property_names[duplicated(property_names)])
for (i in 1:length(dpn)) {
property_names[property_names == dpn] <- paste(property_names[property_names == dpn],
1:length(property_names[property_names == dpn]),
sep = "_"
)
}
} else {
wrn <- NULL
}
property_names <- gsub("/", "_", property_names)
respidx <- unlist(lapply((property_indices + lengthproperty_indices)[1:(n)],
FUN = function(x, l) {
vec <- x:(x + l)
vec
},
l = 8 * nproperties_n - 1
))
properties <- readBin(x[respidx], what = "double", n = n * nproperties_n)
properties <- t(matrix(properties, nrow = nproperties_n))
if (length(property_names) > 0) {
properties[properties == 0] <- NA
}
colnames(properties) <- property_names
return(list(
property_names = property_names,
properties = properties,
warning = wrn
))
}
#' @title get the metadata of the samples in the nircal file
#' @description internal
#' @keywords internal
get_nircal_metadata <- function(connection, n, spctra_start, spcinfo, progress, pb, progress.start, progress.steps) {
metadata <- matrix(NA, nrow = n, ncol = 32)
iprogress <- progress.start
for (i in 1:n) {
## read just the segment with the info (including binary data for numeric info)
seek(connection, where = spcinfo[i], origin = "start")
ac <- readBin(
readBin(connection, what = "raw", n = (spctra_start[i] - spcinfo[i])),
"character"
)
ac <- iconv(ac, from = "latin1", to = "UTF-8", sub = "byte")
ac <- strsplit(ac, "\n")[[1]]
ac <- ac[-length(ac)]
ncac <- 10 + grep("1/cm", ac)
ncac2 <- grep("NIRCal", ac)
ncac2 <- ncac2[length(ncac2)]
ncac <- c(ncac, ncac2)
# nflx <- grep("NIRFlex N500", ac)[1]
nflx <- ncac2 + 11
## Device
i.device <- ac[nflx]
## Created: year, month, day, hours, minutes, seconds
i.created_ymdhms <- ac[ncac[1] - 1:6]
## Modified: year, month, day, hours, minutes, seconds
i.modified_ymdhms <- ac[ncac[2] - 1:6]
## Software version, creator, creator log in
i.versioncreatorlogin <- ac[ncac[1] + c(1, 2, 5)]
## Modified by, modified by log in
i.moodifiedby <- ac[ncac[2] + c(2, 5)]
## Instrument serial number, measurement cell, serial number measurement cell
i.snmcsn <- ac[nflx - c(4, 3, 2)]
gain_s <- grep("Gain Factor", ac)
temp_s <- grep("Instrument Temperature", ac)
temp_sample <- grep("Sample Temperature", ac)
if (length(gain_s) != 0) {
i.gain_factor <- ac[gain_s + c(1, 3)]
} else {
i.gain_factor <- c(NA, NA)
}
if (length(temp_s) != 0) {
i.instrumenttemp <- ac[temp_s + 1]
} else {
i.instrumenttemp <- NA
}
if (length(temp_sample) != 0) {
i.sampletemp <- ac[temp_sample + 1]
} else {
i.sampletemp <- NA
}
i.metadata <- c(
i,
ac[c(1, 7:11)],
i.device,
i.versioncreatorlogin,
i.created_ymdhms,
i.modified_ymdhms,
i.moodifiedby,
i.snmcsn,
i.gain_factor,
i.instrumenttemp,
i.sampletemp
)
if (progress) {
rprogress <- (i * progress.steps) + iprogress
setTxtProgressBar(pb, rprogress)
}
metadata[i, ] <- i.metadata
}
# if (!"matrix" %in% class(metadata)) {
# metadata <- t(metadata)
# }
## not really necessary
metadata <- metadata[order(as.numeric(metadata[, 1])), -1, drop = FALSE]
sf <- function(..i.., ex) {
substring(ex[, ..i..], first = 1 + regexpr(pattern = "\\/", text = ex[, ..i..]))
}
dataex <- sapply(c(1:10, 23:31), FUN = sf, ex = metadata)
datesc <- as.vector(sapply(c(11:22), FUN = sf, ex = metadata))
datesc[nchar(datesc) == 1 & !is.na(datesc)] <- paste("0", datesc[nchar(datesc) == 1 & !is.na(datesc)], sep = "")
datesc <- matrix(datesc, nrow(dataex))
datecreated <- paste(datesc[, 1],
"/",
datesc[, 2],
"/",
datesc[, 3],
" ",
datesc[, 4],
":",
datesc[, 5],
":",
datesc[, 6],
sep = ""
)
datemodified <- paste(datesc[, 7],
"/",
datesc[, 8],
"/",
datesc[, 9],
" ",
datesc[, 10],
":",
datesc[, 11],
":",
datesc[, 12],
sep = ""
)
nms <- c(
"GUID",
"Scans",
"resolution",
"nWavenumbers",
"WavenumberSteps",
"WavenumberStart",
"Device",
"Software Version",
"Creator",
"Creator login",
"Modified by",
"Modifier login",
"Instrument serial",
"Measurement cell",
"Option serial",
"Gain factor",
"Gain",
"Instrument temperature",
"Sample temperature"
)
colnames(dataex) <- nms
dataex <- cbind(dataex, Created = datecreated, Modified = datemodified)
flush(connection)
return(dataex)
}
#' @title get the spectra in the nircal file
#' @description internal
#' @keywords internal
get_nircal_spectra <- function(x, values_s, spctra_start, speclength, n) {
spcidx <- unlist(lapply(spctra_start[1:n],
FUN = function(x, l) x:(x + l),
l = 8 * speclength - 1
))
dspectra <- readBin(x[spcidx], what = "double", n = n * speclength)
dspectra <- t(matrix(dspectra, nrow = speclength, ncol = n))
wavref <- paste(speclength, "Values")
wavstart <- grepRaw(wavref, x, all = TRUE)[3] + nchar(wavref) + 1
widx <- wavstart:(wavstart + values_s[values_s > wavstart][1] - wavstart)
waves <- readBin(x[widx], what = "character")
waves <- strsplit(waves, "\n")[[1]]
waves <- waves[grep("[0-9]{1}/", waves)]
waves <- iconv(waves, from = "ASCII", to = "UTF-8", sub = "byte")
waves <- as.numeric(gsub("[0-9]/", "", waves))
colnames(dspectra) <- waves
return(dspectra)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.