R/misc.R

Defines functions prepCalData repmat capitalize getRes fprintf getMainTitle getSelectedComponents mda.purge mda.purgeCols mda.purgeRows mda.df2mat mda.getexclind mda.getattr mda.setattr mda.inclcols mda.exclcols mda.inclrows mda.exclrows mda.t mda.cbind mda.rbind mda.subset mda.show imshow mda.setimbg mda.data2im mda.im2data

Documented in capitalize fprintf getMainTitle getRes getSelectedComponents imshow mda.cbind mda.data2im mda.df2mat mda.exclcols mda.exclrows mda.getattr mda.getexclind mda.im2data mda.inclcols mda.inclrows mda.purge mda.purgeCols mda.purgeRows mda.rbind mda.setattr mda.setimbg mda.show mda.subset mda.t prepCalData repmat

#' Convert image to data matrix
#'
#' @param img
#' an image (3-way array)
#'
#' @export
mda.im2data <- function(img) {
   width <- dim(img)[2]
   height <- dim(img)[1]
   nchannels <- dim(img)[3]

   npixels <- width * height
   dim(img) <- c(npixels, nchannels)
   attr(img, "width") <- width
   attr(img, "height") <- height

   return(img)
}

#' Convert data matrix to an image
#'
#' @param data
#' data matrix
#'
#' @export
mda.data2im <- function(data) {
   width <- attr(data, "width", exact = TRUE)
   height <- attr(data, "height", exact = TRUE)
   bgpixels <- attr(data, "bgpixels", exact = TRUE)

   if (length(bgpixels) > 0) {
      img <- matrix(NA, nrow = nrow(data) + length(bgpixels), ncol = ncol(data))
      img[-bgpixels, ] <- data
   } else {
      img <- data
   }

   dim(img) <- c(height, width, ncol(data))
   return(img)
}

#' Remove background pixels from image data
#'
#' @param data
#' a matrix with image data
#' @param bgpixels
#' vector with indices or logical values corresponding to background pixels
#'
#' @export
mda.setimbg <- function(data, bgpixels) {
   attrs <- mda.getattr(data)

   if (length(attrs$exclrows) > 0) {
      stop("You can not set background pixels if some of them have been already excluded.")
   }

   # unfold bgpixels to a vector
   dim(bgpixels) <- NULL

   # get indices instead of logical values
   if (is.logical(bgpixels)) {
      bgpixels <- which(bgpixels)
   }

   # correct indices of bgpixels if some of the pixels were already removed
   if (length(attrs$bgpixels) > 0) {
      npixels <- attrs$width * attrs$height
      row.ind <- seq_len(npixels)
      row.ind <- row.ind[-attrs$bgpixels]
      bgpixels <- row.ind[bgpixels]
   }

   # remove corresponding rows and correct attributes
   data <- data[-bgpixels, , drop = FALSE]
   attrs$bgpixels <- unique(c(attrs$bgpixels, bgpixels))

   data <- mda.setattr(data, attrs)
   return(data)
}

#' show image data as an image
#'
#' @param data
#' data with image
#' @param channels
#' indices for one or three columns to show as image channels
#' @param show.excluded
#' logical, if TRUE the method also shows the excluded (hidden) pixels
#' @param main
#' main title for the image
#' @param colmap
#' colormap using to show the intensity levels
#'
#' @export
imshow <- function(data, channels = 1, show.excluded = FALSE,
   main = paste0(" ", colnames(data)[channels]), colmap = "jet") {

   attrs <- mda.getattr(data)

   data <- mda.subset(data, select = channels)
   data <- (data - min(data)) / (max(data) - min(data))
   data <- mda.data2im(data)

   bg <- is.na(data)

   nrows <- dim(data)[1]
   ncols <- dim(data)[2]

   if (is.character(colmap) && length(colmap) == 1) {
      colmap <- if (colmap == "gray") colorRampPalette(c("#000000", "#ffffff"), space = "Lab")(256)
               else mdaplot.getColors(256, NULL, colmap)
   }

   if (length(channels) == 1) {
      nrows <- nrow(data)
      image(t(data[seq(nrows, 1, -1), , 1]), xlim = c(0, 1), ylim = c(0, 1), zlim = c(0, 1),
            main = main, useRaster = TRUE, col = colmap, axes = FALSE)

      if (any(bg)) {
         bgimg <- matrix(NA, nrows, ncols)
         bgimg[bg[, , 1]] <- 0
         rasterImage(bgimg, 0, 0, 1, 1)
      }
   } else {
      if (any(bg)) data[bg] <- 0
      plot(0, main = main, type = "n", xaxs = "i", yaxs = "i", xlab = "", ylab = "",
           xlim = c(0, 1), ylim = c(0, 1), axes = FALSE)
      rasterImage(data, 0, 0, 1, 1)
   }

   # hide excluded pixels with dark gray color
   if (show.excluded == FALSE && length(attrs$exclrows) > 0) {
      npixels <- nrows * ncols
      ind <- seq_len(npixels)
      if (length(attrs$bgpixels) > 0) ind <- ind[-attrs$bgpixels]
      eximage <- rep(NA, npixels)
      eximage[ind[attrs$exclrows]] <- 0.25
      dim(eximage) <- c(nrows, ncols)
      rasterImage(eximage, 0, 0, 1, 1)
   }

}

#' Wrapper for show() method
#'
#' @param x
#' data set
#' @param n
#' number of rows to show
#'
#' @export
mda.show <- function(x, n = 50) {
   exclrows <- attr(x, "exclrows", exact = TRUE)
   exclcols <- attr(x, "exclcols", exact = TRUE)

   name <- attr(x, "name", exact = TRUE)

   if (!is.null(name) && nchar(name) > 0) {
      fprintf("%s\n%s\n", name, paste(rep("-", nchar(name)), collapse = ""))
   }

   if (!is.null(exclrows)) {
      x <- x[-exclrows, , drop = FALSE]
   }

   if (!is.null(exclcols)) {
      x <- x[, -exclcols, drop = FALSE]
   }

   if (n > nrow(x)) n <- nrow(x)
   show(x[seq_len(n), , drop = FALSE])
}

#' A wrapper for subset() method with proper set of attributed
#'
#' @param x
#' dataset (data frame or matrix)
#' @param subset
#' which rows to keep (indices, names or logical values)
#' @param select
#' which columns to select (indices, names or logical values)
#'
#' @return
#' a data with the subset
#'
#' @details
#' The method works similar to the standard \code{subset()} method, with minor differences. First
#' of all it keeps (and correct, if necessary) all important attributes. If only columns are
#' selected, it keeps all excluded rows as excluded. If only rows are selected, it keeps all
#' excluded columns. If both rows and columns are selected it removed all excluded elements first
#' and then makes the subset.
#'
#' The parameters \code{subset} and \code{select} may each be a vector with numbers or nanes
#' without excluded elements, or a logical expression.
#'
#' @export
mda.subset <- function(x, subset = NULL, select = NULL) {

   if (is.null(x)) return(NULL)

   attrs <- mda.getattr(x)

   if (!is.null(subset)) {
      if (is.logical(subset) & !is.null(attrs$exclrows))
         subset <- subset[-attrs$exclrows]

      # remove excluded rows first
      if (!is.null(attrs$exclrows))
         x <- x[-attrs$exclrows, , drop = F]

      # get numeric indices for the rows and subset them
      subset <- mda.getexclind(subset, rownames(x), nrow(x))
      x <- x[subset, , drop = FALSE]

      # correct attributes
      if (!is.null(attrs$yaxis.values)) {
         if (!is.null(attrs$exclrows)) attrs$yaxis.values <- attrs$yaxis.values[-attrs$exclrows]
         attrs$yaxis.values <- attrs$yaxis.values[subset]
      }

      attrs$exclrows <- NULL
   }

   if (!is.null(select)) {
      if (is.logical(select) && !is.null(attrs$exclcols))
         select <- select[-attrs$exclcols]

      # remove excluded rows first
      if (!is.null(attrs$exclcols))
         x <- x[, -attrs$exclcols, drop = F]

      # get numeric indices for the rows and subset them
      select <- mda.getexclind(select, colnames(x), ncol(x))
      x <- x[, select, drop = F]

      # correct attributes
      if (!is.null(attrs$xaxis.values)) {
         if (!is.null(attrs$exclcols)) attrs$xaxis.values <- attrs$xaxis.values[-attrs$exclcols]
         attrs$xaxis.values <- attrs$xaxis.values[select]
      }

      attrs$exclcols <- NULL
   }

   x <- mda.setattr(x, attrs)
   return(x)
}

#' A wrapper for rbind() method with proper set of attributes
#'
#' @param ...
#' datasets (data frames or matrices) to bind
#'
#' @return
#' the merged datasets
#'
#' @export
mda.rbind <- function(...) {
   objects <- list(...)
   nobj <- length(objects)

   attrs <- mda.getattr(objects[[1]])
   out.exclrows <- attrs$exclrows
   out.yaxis.values <- attrs$yaxis.values

   out.x <- objects[[1]]
   for (i in 2:nobj) {
      x <- objects[[i]]
      exclrows <- attr(x, "exclrows", exact = TRUE)
      yaxis.values <- attr(x, "yaxis.values")
      if (!is.null(exclrows)) out.exclrows <- c(out.exclrows, exclrows + nrow(out.x))
      if (is.null(out.yaxis.values) || is.null(yaxis.values))
         out.yaxis.values <- NULL
      else
         out.yaxis.values <- c(out.yaxis.values, yaxis.values)
      out.x <- rbind(out.x, x)
   }

   out.x <- mda.setattr(out.x, attrs)
   attr(out.x, "exclrows") <- out.exclrows
   attr(out.x, "yaxis.values") <- out.yaxis.values

   return(out.x)
}

#' A wrapper for cbind() method with proper set of attributes
#'
#' @param ...
#' datasets (data frames or matrices) to bind
#'
#' @return
#' the merged datasets
#'
#' @export
mda.cbind <- function(...) {
   objects <- list(...)
   nobj <- length(objects)

   attrs <- mda.getattr(objects[[1]])
   out.exclcols <- attrs$exclcols
   out.xaxis.values <- attrs$xaxis.values
   out.x <- objects[[1]]

   for (i in 2:nobj) {
      x <- objects[[i]]
      exclcols <- attr(x, "exclcols")
      xaxis.values <- attr(x, "xaxis.values")
      if (!is.null(exclcols))
         out.exclcols <- c(out.exclcols, exclcols + ncol(out.x))
      if (is.null(out.xaxis.values) || is.null(xaxis.values))
         out.xaxis.values <- NULL
      else
         out.xaxis.values <- c(out.xaxis.values, xaxis.values)
      out.x <- cbind(out.x, x)
   }

   out.x <- mda.setattr(out.x, attrs)
   attr(out.x, "exclcols") <- out.exclcols
   attr(out.x, "xaxis.values") <- out.xaxis.values

   return(out.x)
}

#' A wrapper for t() method with proper set of attributes
#'
#' @param x
#' dataset (data frames or matrices) to transpose
#'
#' @return
#' the transposed dataset
#'
#' @export
mda.t <- function(x) {
   attrs <- mda.getattr(x)
   out.attrs <- attrs
   out.attrs$exclrows <- attrs$exclcols
   out.attrs$exclcols <- attrs$exclrows
   out.attrs$xaxis.name <- attrs$yaxis.name
   out.attrs$yaxis.name <- attrs$xaxis.name
   out.attrs$xaxis.values <- attrs$yaxis.values
   out.attrs$yaxis.values <- attrs$xaxis.values

   x <- t(x)
   x <- mda.setattr(x, out.attrs)
}

#' Exclude/hide rows in a dataset
#'
#' @param x
#' dataset (data frame or matrix).
#' @param ind
#' indices of rows to exclude (numbers, names or logical values)
#'
#' @return
#' dataset with excluded rows
#'
#' @details
#' The method assign attribute 'exclrows', which contains number of rows, which should be
#' excluded/hidden from calculations and plots (without removing them physically). The
#' argument \code{ind} should contain rows numbers (excluding already hidden), names or logical
#' values.
#'
#' @export
mda.exclrows <- function(x, ind) {

   if (length(ind) < 1) return(x)

   excl.rows <- attr(x, "exclrows", exact = TRUE)
   nrows.tot <- nrow(x)
   nrows.excl <- length(excl.rows)

   if (nrows.excl == 0) {
      # no objects are excluded yet
      attr(x, "exclrows") <- mda.getexclind(ind, rownames(x), nrows.tot)
   } else {
      # some objects were excluded before
      if (is.logical(ind))
         ind <- ind[-excl.rows]
      ind <- mda.getexclind(ind, rownames(x)[-excl.rows], nrows.tot - nrows.excl)
      ind.tot <- seq_len(nrows.tot)
      ind.tot <- ind.tot[-excl.rows]
      attr(x, "exclrows") <- sort(unique(c(ind.tot[ind], excl.rows)))
   }

   # check that number of rows is still sufficient
   if (is.null(nrow(x)) || nrow(x) == 0) {
      stop("No rows left when excluded hidden values.")
   }

   return(x)
}

#' include/unhide the excluded rows
#'
#' @param x
#' dataset (data frame or matrix).
#' @param ind
#' number of excluded rows to include
#'
#' @return
#' dataset with included rows
#'
#' @description
#' include rows specified by user (earlier excluded using mda.exclrows)
#'
#' @export
mda.inclrows <- function(x, ind) {
   excl.rows <- attr(x, "exclrows", exact = TRUE)
   ind.log <- excl.rows %in% ind
   attr(x, "exclrows") <- excl.rows[!ind.log]

   return(x)
}

#' Exclude/hide columns in a dataset
#'
#' @param x
#' dataset (data frame or matrix).
#' @param ind
#' indices of columns to exclude (numbers, names or logical values)
#'
#' @return
#' dataset with excluded columns
#'
#' @details
#' The method assign attribute 'exclcols', which contains number of columns, which should be
#' excluded/hidden from calculations and plots (without removing them physically). The argument
#' \code{ind} should contain column numbers (excluding already hidden), names or logical values.
#'
#' @export
mda.exclcols <- function(x, ind) {
   if (length(ind) < 1) return(x)

   excl.cols <- attr(x, "exclcols", exact = TRUE)
   ncols.tot <- ncol(x)
   ncols.excl <- length(excl.cols)

   if (ncols.excl == 0) {
      # no objects are excluded yet
      attr(x, "exclcols") <- mda.getexclind(ind, colnames(x), ncols.tot)
      return(x)
   }

   # some objects were excluded before
   if (is.logical(ind)) ind <- ind[-excl.cols]
   ind <- mda.getexclind(ind, colnames(x)[-excl.cols], ncols.tot - ncols.excl)
   ind.tot <- seq_len(ncols.tot)
   ind.tot <- ind.tot[-excl.cols]
   attr(x, "exclcols") <- sort(unique(c(ind.tot[ind], excl.cols)))
   return(x)
}

#' Include/unhide the excluded columns
#'
#' @param x
#' dataset (data frame or matrix).
#' @param ind
#' number of excluded columns to include
#'
#' @return
#' dataset with included columns.
#'
#' @description
#' include colmns specified by user (earlier excluded using mda.exclcols)
#'
#' @export
mda.inclcols <- function(x, ind) {
   excl.cols <- attr(x, "exclcols", exact = TRUE)
   ind.log <- excl.cols %in% ind
   attr(x, "exclcols") <- excl.cols[!ind.log]

   return(x)
}

#' Set data attributes
#'
#' @description
#' Set most important data attributes (name, xvalues, excluded rows and columns, etc.) to a dataset
#'
#' @param x
#' a dataset
#' @param attrs
#' list with attributes
#' @param type
#' a text variable telling which attributes to set ('all', 'row', 'col')
#'
#' @export
mda.setattr <- function(x, attrs, type = "all") {

   attr(x, "name") <- attrs$name
   attr(x, "width") <- attrs$width
   attr(x, "height") <- attrs$height
   attr(x, "bgpixels") <- attrs$bgpixels

   if (type != "col") {
      attr(x, "yaxis.name") <- attrs$yaxis.name
      attr(x, "yaxis.values") <- attrs$yaxis.values
      attr(x, "exclrows") <- attrs$exclrows
   }

   if (type != "row") {
      attr(x, "xaxis.name") <- attrs$xaxis.name
      attr(x, "xaxis.values") <- attrs$xaxis.values
      attr(x, "exclcols") <- attrs$exclcols
   }

   return(x)
}

#'
#' Get data attributes
#'
#' @description
#' Returns a list with important data attributes (name, xvalues, excluded rows and columns, etc.)
#'
#' @param x
#' a dataset
#'
#' @export
mda.getattr <- function(x) {
   attrs <- list()

   attrs$name <- attr(x, "name", exact = TRUE)
   attrs$exclrows <- attr(x, "exclrows", exact = TRUE)
   attrs$exclcols <- attr(x, "exclcols", exact = TRUE)
   attrs$xaxis.values <- attr(x, "xaxis.values", exact = TRUE)
   attrs$yaxis.values <- attr(x, "yaxis.values", exact = TRUE)
   attrs$xaxis.name <- attr(x, "xaxis.name", exact = TRUE)
   attrs$yaxis.name <- attr(x, "yaxis.name", exact = TRUE)
   attrs$width <- attr(x, "width", exact = TRUE)
   attrs$height <- attr(x, "height", exact = TRUE)
   attrs$bgpixels <- attr(x, "bgpixels", exact = TRUE)

   return(attrs)
}

#' Get indices of excluded rows or columns
#'
#' @param excl
#' vector with excluded values (logical, text or numbers)
#' @param names
#' vector with names for rows or columns
#' @param n
#' number of rows or columns
#'
#' @export
mda.getexclind <- function(excl, names, n) {
   nitems <- if (is.logical(excl)) sum(excl) else length(excl)

   if (is.character(excl))
      excl <- which(names %in% excl)
   if (is.logical(excl))
      excl <- which(excl)

   if (length(excl) < nitems)
      stop("At least one index or name is incorrect.")

   if (length(excl) > 0 && (!is.numeric(excl) || min(excl) < 1 || max(excl) > n))
      stop("At least one index or name is incorrect.")

   return(excl)
}

#' Convert data frame to a matrix
#'
#' @description
#' The function converts data frame to a numeric matrix.
#'
#' @param x
#' a data frame
#' @param full
#' logical, if TRUE number of dummy variables for a factor will be the same as number of levels,
#' otherwise by one smaller
#'
#' @details
#' If one or several columns of the data frame are factors they will be converted to a set of dummy
#' variables. If any columns/rows were hidden in the data frame they will remain hidden in the
#' matrix. If there are factors among the hidden columns, the corresponding dummy variables will be
#' hidden as well.
#'
#' All other attributes (names, axis names, etc.) will be inherited.
#'
#' @return
#' a numeric matrix
#'
#' @export
mda.df2mat <- function(x, full = FALSE) {
   attrs <- mda.getattr(x)
   if (is.null(x) || is.matrix(x) || is.vector(x)) return(x)

   if (is.factor(x)) {
      x <- data.frame(x)
   }

   if (any(sapply(x, is.character))) {
      stop("At least one column in the provided data frame has text values.", call. = FALSE)
   }

   # get indices of factor and numeric columns
   col.fac <- unlist(lapply(x, is.factor))
   col.num <- which(!col.fac)
   col.fac <- which(col.fac)

   dummy <- function(i, x, full = FALSE) {
      x <- x[, i]
      n <- if (full) nlevels(x) else nlevels(x) - 1
      y <- matrix(seq_len(n), nrow = length(x), ncol = n, byrow = TRUE)
      d <- y == as.numeric(x)
      colnames(d) <- levels(x)[seq_len(n)]
      attr(d, "cols.info") <- c(i, n)
      return(d)
   }

   if (is.null(col.fac) || length(col.fac) == 0) {
      # no factors among columns - easy job
      x <- as.matrix(x)
      x <- mda.setattr(x, attrs)
      return(x)
   }

   exclcols.fac.ind <- NULL
   exclcols.num.ind <- NULL
   if (!is.null(attrs$exclcols)) {
      if (is.character(attrs$exclcols)) attrs$exclcols <- which(colnames(x) %in% attrs$exclcols)
      if (is.logical(attrs$exclcols)) attrs$exclcols <- which(attrs$exclcols)

      exclcols.fac.ind <- which(col.fac %in% attrs$exclcols) # hidden factors
      exclcols.num.ind <- which(col.num %in% attrs$exclcols) # hidden numeric columns
   }

   # split data to numeric columns and factors
   num.data <- if (length(col.fac) < ncol(x)) as.matrix(x[, -col.fac, drop = FALSE])
   fac.data <- x[, col.fac, drop = FALSE]

   fac.data.hidden <- NULL
   if (length(exclcols.fac.ind) > 0) {
      fac.data.hidden <- fac.data[, exclcols.fac.ind, drop = FALSE]
      fac.data <- fac.data[, -exclcols.fac.ind, drop = FALSE]
   }

   # convert all non-excluded factors to dummy variables
   fac.data <- lapply(seq_len(ncol(fac.data)), dummy, x = fac.data, full = full)
   fac.data <- do.call(cbind, fac.data)

   # convert all excluded factors to numeric values
   exclcols.fac.ind <- NULL
   if (!is.null(fac.data.hidden)) {
      fac.data.hidden <- as.matrix(as.data.frame(lapply(fac.data.hidden, as.numeric)))
      n.incl.col <- ncol(num.data) + ncol(fac.data)
      exclcols.fac.ind <- (n.incl.col + 1):(n.incl.col + ncol(fac.data.hidden))
   }

   # combine the data values and set attributes
   x <- cbind(num.data, fac.data, fac.data.hidden)

   # correct and set arguments
   attrs$exclcols <- c(exclcols.num.ind, exclcols.fac.ind)
   x <- mda.setattr(x, attrs)
   return(x)
}

#' Removes excluded (hidden) rows from data
#'
#' @param data
#' data frame or matrix with data
#'
#' @export
mda.purgeRows <- function(data) {
   attrs <- mda.getattr(data)
   if (length(attrs$exclrows) == 0) return(data)
   new_data <- data[-attrs$exclrows, , drop = FALSE]
   attrs$yaxis.values <- if (!is.null(attrs$yaxis.values)) attrs$yaxis.values[-attrs$exclrows]
   attrs$exclrows <- NULL
   new_data <- mda.setattr(new_data, attrs)
   return(new_data)
}

#' Removes excluded (hidden) colmns from data
#'
#' @param data
#' data frame or matrix with data
#'
#' @export
mda.purgeCols <- function(data) {
   attrs <- mda.getattr(data)
   if (length(attrs$exclcols) == 0) return(data)

   new_data <- data[, -attrs$exclcols, drop = FALSE]
   attrs$xaxis.values <- if (!is.null(attrs$xaxis.values)) attrs$xaxis.values[-attrs$exclcols]
   attrs$exclcols <- NULL
   new_data <- mda.setattr(new_data, attrs)
   return(new_data)
}

#' Removes excluded (hidden) rows and colmns from data
#'
#' @param data
#' data frame or matrix with data
#'
#' @export
mda.purge <- function(data) {
   return(mda.purgeCols(mda.purgeRows(data)))
}

#' Get selected components
#'
#' @description
#' returns number of components depending on a user choice
#'
#' @param obj
#' an MDA model or result object (e.g. \code{pca}, \code{pls}, \code{simca}, etc)
#' @param ncomp
#' number of components to select, provided by user
#'
#' @details
#' Depedning on a user choice it returns optimal number of component for the model (if
#' use did not provide any value) or check the user choice for correctness and returns
#' it back
#'
getSelectedComponents <- function(obj, ncomp = NULL) {
   if (!is.null(ncomp)) return(ncomp)
   return(if (is.null(obj$ncomp.selected)) 1 else obj$ncomp.selected)
}

#' Get main title
#'
#' @description
#' returns main title for a plot depending on a user choice
#'
#' @param main
#' main title of a plot, provided by user
#' @param ncomp
#' number of components to select, provided by user
#' @param default
#' default title for the plot
#'
#' @details
#' Depedning on a user choice it returns main title for a plot
#'
getMainTitle <- function(main, ncomp, default) {
   if (!is.null(main)) return(main)
   return(if (is.null(ncomp)) default else sprintf("%s (ncomp = %d)", default, ncomp))
}

#' Imitation of fprinf() function
#'
#' @param ...
#' arguments for sprintf function
#'
#' @export
fprintf <- function(...) {
   cat(sprintf(...))
}

#' Return list with valid results
#'
#' @param res
#' list with results
#' @param classname
#' name of class (for result object) to look for
#'
#' @export
getRes <- function(res, classname = "ldecomp") {

   if (!is.list(res)) {
      stop("Parameter 'res' should be a list with result objects.")
   }

   res <- res[sapply(res, function(x) classname %in% class(x))]

   if (length(res) == 0) {
      stop("No valid results provided.")
   }

   return(res)
}

#' Capitalize text or vector with text values
#'
#' @param str
#' text of vector with text values
#'
#' @export
capitalize <- function(str) {
   return(sapply(str,  function(s) paste0(toupper(substring(s, 1, 1)), substring(s, 2))))
}

#' Replicate matric x
#'
#' @param x
#' original matrix
#' @param nrows
#' number of times replicate matrix row wise
#' @param ncols
#' number of times replicate matrix columns wise
#'
#' @export
repmat <- function(x, nrows, ncols = nrows) {
   x <- as.matrix(x)
   return(matrix(1, nrows, ncols) %x% x)
}


#' Prepares calibration data
#'
#' @param x
#' matrix or data frame with values (calibration set)
#' @param exclrows
#' rows to be excluded from calculations (numbers, names or vector with logical values)
#' @param exclcols
#' columns to be excluded from calculations (numbers, names or vector with logical values)
#' @param min.nrows
#' smallest number of rows which must be in the dataset
#' @param min.ncols
#' smallest number of columns which must be in the dataset
#'
#' @export
prepCalData <- function(x, exclrows = NULL, exclcols = NULL, min.nrows = 1, min.ncols = 2) {

   # check that x has a dimension
   stopifnot("Data values must be provided in form of a matrix or a data frame." = !is.null(dim(x)))

   if (is.data.frame(x) && any(sapply(x, is.character))) {
      stop("At least one column in the provided data frame has text values.", call. = FALSE)
   }

   # exclude columns if "exclcols" is provided
   if (length(exclcols) > 0) {
      x <- mda.exclcols(x, exclcols)
   }

   # exclude rows if "exclrows" is provided
   if (length(exclrows) > 0) {
      x <- mda.exclrows(x, exclrows)
   }

   # check number of rows
   if (nrow(x) - length(attr(x, "exclrows")) < min.nrows) {
      stop(sprintf("Dataset should contain at least %d measurements (rows).", min.nrows))
   }

   # check number of columns
   if (ncol(x) - length(attr(x, "exclcols")) < min.ncols) {
      stop(sprintf("Dataset should contain at least %d variables (columns).", min.ncols))
   }

   return(x)
}

Try the mdatools package in your browser

Any scripts or data that you put into this service are public.

mdatools documentation built on Sept. 13, 2021, 9:07 a.m.