R/sample_sel.R

In TIMP: Fitting Separable Nonlinear Models in Spectroscopy and Microscopy

"sample_sel" <-
  function(data, sample = c(), sample_time = c(), sample_lambda = c(),
           sel_time = c(), sel_lambda = c(), sel_time_ab = c(),
           sel_lambda_ab = c(), sel_special = list()) {
    increasing_x2 <- if (data@x2[1] < data@x2[2]) TRUE else FALSE
    if (length(sel_time) == 2) {
      if (sel_time[2] > data@nt) {
        sel_time[2] <- data@nt
      }
      data@psi.df <- as.matrix(data@psi.df[sel_time[1]:sel_time[2], ])
      data@x <- data@x[sel_time[1]:sel_time[2]]
      if (data@simdata) {
        data@C2 <- data@C2[sel_time[1]:sel_time[2], ]
      }
    }
    if (length(sel_time_ab) == 2) {
      tmin <- which(data@x >= sel_time_ab[1])[1]
      tmax <- which(data@x <= sel_time_ab[2])[length(
        which(data@x <= sel_time_ab[2])
      )]
      data@psi.df <- as.matrix(data@psi.df[tmin:tmax, ])
      data@x <- data@x[tmin:tmax]
      if (data@simdata) {
        data@C2 <- data@C2[tmin:tmax, ]
      }
    }
    if (length(sel_lambda) == 2) {
      lmin <- sel_lambda[1]
      lmax <- sel_lambda[2]
      data@psi.df <- as.matrix(data@psi.df[, lmin:lmax])

      data@nl <- ncol(data@psi.df)
      data@x2 <- data@x2[lmin:lmax]
      if (data@simdata) {
        data@E2 <- data@E2[lmin:lmax, ]
      }
    }
    if (length(sel_lambda_ab) == 2) {
      if (increasing_x2) {
        lmin <- which(data@x2 >= sel_lambda_ab[1])[1]
        lmax <- which(data@x2 <= sel_lambda_ab[2])[length(
          which(data@x2 <= sel_lambda_ab[2])
        )]
      } else {
        lmin <- which(data@x2 <= sel_lambda_ab[1])[1]
        lmax <- which(data@x2 >= sel_lambda_ab[2])[length(
          which(data@x2 >= sel_lambda_ab[2])
        )]
      }
      data@psi.df <- as.matrix(data@psi.df[, lmin:lmax])
      data@nt <- nrow(data@psi.df)

      data@x2 <- data@x2[lmin:lmax]
      if (data@simdata) {
        data@E2 <- data@E2[, lmin:lmax]
      }
    }
    if (length(sel_special) > 0) {
      for (i in 1:length(sel_special)) {
        reg <- sel_special[[i]]
        if (increasing_x2) {
          lmin <- which(data@x2 >= reg[1])[1]
          lmax <- which(data@x2 <= reg[2])[length(which(data@x2 <= reg[2]))]
        } else {
          lmin <- which(data@x2 <= reg[1])[1]
          lmax <- which(data@x2 >= reg[2])[length(which(data@x2 >= reg[2]))]
        }
        if (i == 1) {
          datanew <- as.matrix(data@psi.df[-(reg[3]:reg[4]), lmin:lmax])
        } else {
          datanew <- cbind(datanew, as.matrix(data@psi.df[
            -(reg[3]:reg[4]),
            lmin:lmax
          ]))
        }
      }
      data@psi.df <- datanew
      data@x <- data@x[-(sel_special[[1]][3]:sel_special[[1]][4])]
    }
    data@nl <- length(data@x2)
    data@nt <- length(data@x)
    if (sample != 1) {
      data@psi.df <- as.matrix(data@psi.df[
        seq(1, data@nt, by = sample),
        seq(1, data@nl, by = sample)
      ])
      data@x <- data@x[seq(1, data@nt, by = sample)]
      data@x2 <- data@x2[seq(1, data@nl, by = sample)]
      data@nl <- length(data@x2)
      data@nt <- length(data@x)
    } else {
      if (is.matrix(data@psi.df)) {
        data@psi.df <- as.matrix(data@psi.df[
          seq(1, data@nt,
            by = sample_time
          ),
          seq(1, data@nl,
            by = sample_lambda
          )
        ])
      }
      data@x <- data@x[seq(1, data@nt, by = sample_time)]
      data@x2 <- data@x2[seq(1, data@nl, by = sample_lambda)]
      data@nl <- length(data@x2)
      data@nt <- length(data@x)
    }
    data
  }