omxGenerateThresholds <- function(data, threshNames, threshLabels, lowVals, highVals) { if(missing(data) || !is.data.frame(data)) { stop("argument 'data' must be a data frame object") } if(missing(threshNames) || !is.vector(threshNames) || !is.character(threshNames)) { stop("argument 'threshNames' must be a character vector") } if(missing(threshLabels) || !is.vector(threshLabels) || !is.character(threshLabels)) { stop("argument 'threshLabels' must be a character vector") } if(missing(lowVals) || !is.vector(lowVals) || !is.vector(lowVals) || !is.numeric(lowVals)) { stop("argument 'lowVals' must be a numeric vector") } if(missing(highVals) || !is.vector(highVals) || !is.vector(highVals) || !is.numeric(highVals)) { stop("argument 'highVals' must be a numeric vector") } lengths <- sapply(c(threshNames, threshLabels, lowVals, highVals), length) if (any(lengths != lengths[[1]])) { stop("The vector arguments must all be of the same length") } if (any(lowVals > highVals)) { stop(paste("'lowVals' must be less than", "or equal to 'highVals' for all respective", "elements.")) } missingNames <- setdiff(threshNames, colnames(data)) if (length(missingNames) > 0) { msg <- paste("The following names are in", omxQuotes("threshNames"), "but are missing from", "the column names of the data set:", omxQuotes(missingNames)) stop(msg) } select <- data[,threshNames] allordered <- sapply(select, is.ordered) if (any(!allordered)) { stop("The selected columns of the data frame must be ordered factors") } getlevels <- lapply(select, levels) getlengths <- sapply(getlevels, length) - 1 values <- generateThresholdValuesMatrix(lowVals, highVals, getlengths) free <- generateThresholdFreeMatrix(getlengths) labels <- generateThresholdLabelsMatrix(threshLabels, getlengths) retval <- mxMatrix("Full", values = values, free = free, labels = labels, dimnames = list(c(), threshNames), name = "thresholds") return(retval) } generateThresholdValuesMatrix <- function(lowVals, highVals, getlengths) { nrows <- max(getlengths) ncols <- length(getlengths) retval <- matrix(0, nrows, ncols) for(i in 1:ncols) { len <- getlengths[[i]] values <- seq(lowVals[[i]], highVals[[i]], length.out = len) retval[1:len, i] <- values } return(retval) } generateThresholdLabelsMatrix <- function(threshLabels, getlengths) { nrows <- max(getlengths) ncols <- length(getlengths) retval <- matrix(as.character(NA), nrows, ncols) for(i in 1:ncols) { len <- getlengths[[i]] base <- threshLabels[[i]] columnLabels <- paste(base, c(1:len), sep = '') retval[1:len, i] <- columnLabels } return(retval) } generateThresholdFreeMatrix <- function(getlengths) { nrows <- max(getlengths) ncols <- length(getlengths) retval <- matrix(FALSE, nrows, ncols) for(i in 1:ncols) { retval[1:getlengths[[i]], i] <- TRUE } return(retval) }