R/utils.r

In markheckmann/OpenRepGrid: Tools to Analyze Repertory Grid Data

# Variance, standard deviation and covariance without Bessel's correction


has_only_0_1_ratings <- function(x) {
  r <- ratings(x)
  return(all(r %in% 0:1))
}


covpop <- function(x, y, na.rm = TRUE) {
  x <- unlist(x)
  y <- unlist(y)
  if (na.rm) { # delete missings
    index <- is.na(x | is.na(y))
    x <- x[!index]
    y <- y[!index]
  }
  n <- length(x)
  ((n - 1) / n) * cov(x = x, y = y) # undo Bessel's correction
}

varpop <- function(x, na.rm = FALSE) {
  covpop(x = x, y = x, na.rm = na.rm) # undo Bessel's correction
}

sdpop <- function(...) {
  sqrt(varpop(...))
}


# factorial function
# wrapper for convenience
fac <- function(x) gamma(1 + x)

joinString <- function(x) {
  paste(unlist(x), sep = "", collapse = " ")
}

trimBlanksInString <- function(x) {
  sub("^[[:space:]]*(.*?)[[:space:]]*$", "\\1", x, perl = TRUE)
}


baseSplitStringInt <- function(text, availwidth = 1, cex = 1) # function to split text in base graphics
{
  if (is.expression(text)) { # expressions cannot be split
    return(text)
    # break
  }
  if (identical(text, NULL)) text <- ""
  if (identical(text, NA)) text <- ""
  if (identical(text, character(0))) text <- ""
  if (text == "") {
    return(paste(text))
    # break
  }

  strings <- strsplit(as.character(text), " ")[[1]]
  if (length(strings) == 1) {
    return(paste(strings))
    # break
  }
  newstring <- strings[1]
  linewidth <- strwidth(newstring, cex = cex)
  gapwidth <- strwidth(" ", cex = cex)

  for (i in 2:length(strings)) {
    width <- strwidth(strings[i], cex = cex)
    if (linewidth + gapwidth + width < availwidth) {
      sep <- " "
      linewidth <- linewidth + gapwidth + width
    } else {
      sep <- "\n"
      linewidth <- width
    }
    newstring <- paste(newstring, strings[i], sep = sep)
  }
  newstring
}


baseSplitString <- function(text, availwidth = 1, cex = 1) {
  as.vector(sapply(text, baseSplitStringInt,
    availwidth = availwidth, cex = cex
  ))
}


# makeStandardRangeColorRamp() creates color ramp for supplied colors that takes
# values between [0,1] and returns a hex color value
#
makeStandardRangeColorRamp <- function(colors, na.col = "#FFFFFF", ...) {
  ramp <- colorRamp(colors, ...)
  function(x) {
    is.na(x) <- is.na(x) # convert NaN values to NA
    na.index <- is.na(x)
    x[na.index] <- 0 # overwrite so color can be determined
    x <- ramp(x) # actual color calculation
    col <- rgb(x[, 1], x[, 2], x[, 3], maxColorValue = 255)
    col[na.index] <- na.col # replace na indices with default NA color
    col
  }
}


#' modifyListNull
#'
#' TODO: a modified version of modifyList that does not overwrite elements
#' if they are NULL in the supplied list
#'
#' @param   x
#' @param   val
#' @return  list
#' @noRd
#'
modifyListNull <- function(x, val) {
  stopifnot(is.list(x), is.list(val))
  xnames <- names(x)
  for (v in names(val)) {
    x[[v]] <- if (v %in% xnames && is.list(x[[v]]) && is.list(val[[v]])) {
      Recall(x[[v]], val[[v]])
    } else if (!is.null(val[[v]])) { # this part was extended to check if element is NULL
      val[[v]]
    } else {
      x[[v]]
    }
  }
  x
}
# l1 <- list(a=1, b=2)
# l2 <- list(a=NULL, b=3)
# modifyListNull(l1, l2)
# modifyList(l1,l2)
# modifyListNull(l2, l1)

#' modifyListNA
#'
#' TODO: a modified version of modifyList that does not overwrite elements
#' if they are NA in the supplied list
#' @param   x
#' @param   val
#' @return  list
#' @noRd
#'
modifyListNA <- function(x, val) {
  stopifnot(is.list(x), is.list(val))
  xnames <- names(x)
  for (v in names(val)) {
    x[[v]] <- if (v %in% xnames && is.list(x[[v]]) && is.list(val[[v]])) {
      Recall(x[[v]], val[[v]])
    } else if (!is.na(val[[v]])) { # this part was extended to check if element is NULL
      val[[v]]
    } else {
      x[[v]]
    }
  }
  x
}
# l1 <- list(a=1, b=2)
# l2 <- list(a=NA, b=3)
# modifyListNA(l1, l2)
# modifyList(l1,l2)
# modifyListNA(l2, l1)

# l1 <- list(t=list(a=1, b=2))
# l2 <- list(t=list(a=NA, b=3))
# modifyListNA(l1, l2)
# modifyList(l1,l2)
# modifyListNA(l2, l1)


# //////////////////////////////////////////////////////////////////////////////
#' bring vector values into ring form
#'
#' the values of a vector that are outside of a given range are remapped
#' to the values of the range. This function is useful for loops over rows and
#' columns of a matrix if the
#'
#' @param x       vector
#' @param upper   upper limit of range (lower is one. TODO: maybe extend???)
#' @return vector
#' @export
#' @keywords internal
#' @examples \dontrun{
#' ring(1:10, 3)
#'
#' m <- matrix(1:12, ncol = 4)
#' for (i in 1:12) {
#'   print(m[ring(i, 3), map(i, 4)])
#' }
#' }
#'
ring <- function(x, upper) {
  res <- x %% upper
  res[res == 0] <- upper
  res
}


# //////////////////////////////////////////////////////////////////////////////
#' map a value onto others
#'
#' @param x      vector
#' @param each   number of cuts
#' @return vector
#' @export
#' @keywords internal
#' @examples \dontrun{
#' map(1:10, 3)
#'
#' m <- matrix(1:12, ncol = 4)
#' for (i in 1:12) {
#'   print(m[ring(i, 3), map(i, 4)])
#' }
#' }
#'
map <- function(x, each) {
  ceiling(x / each)
}


# //////////////////////////////////////////////////////////////////////////////
#' order one vector by another
#'
#' small wrapper to order one vector by another, hardly worth a function
#'
#' @param x   vector
#' @param y   vector
#' @return    vector
#' @export
#' @keywords internal
orderBy <- function(x, y) y[order(x)]


# //////////////////////////////////////////////////////////////////////////////
#' make ascending and descending vector
#'
#' along a given length n make ascending indices until reaching
#' the midpoint and descend afterwards again.
#'
#' @param n       `integer` The length of the indexes
#' @param type    (integer, default=1). If 1 the cascade index is returned.
#'                2 returns the index of left and right side, 3 returns the length
#'                of the left and right index vector
#' @return  vector (type 1 or 3) or list (type 2)
#' @export
#' @keywords internal
#' @examples \dontrun{
#' for (n in 1:10) {
#'   print(cascade(n))
#' }
#' }
cascade <- function(n, type = 1) {
  if (type == 2) {
    list(
      left = (1:n)[0:floor(n / 2)],
      right = rev((n:1)[0:ceiling(n / 2)])
    )
  } else if (type == 3) {
    c(
      left = length((1:n)[0:floor(n / 2)]),
      right = length((n:1)[0:ceiling(n / 2)])
    )
  } else {
    c((1:n)[0:floor(n / 2)], rev((1:n)[0:ceiling(n / 2)]))
  }
}


# insertAt kreiert die Indizes für das ineinanderfügen von zwei Vektoren, Listen etc.
# index.base		Index des Objekts in das eingefügt werden soll (meist 1,2,3 etc.)
# index.insert		Index der Stellen an denen ein Objekt eingefügt werden soll
#
# 1 2 3 4		1  2  3  4
# 1   3		   1           5
#   2 3 4 5
# 1    4
#   2 3 5 6
# 1    4

#' insertAt
#'
#' TODO: a modified version of modifyList that does not overwrite elements
#' if they are NA in the supplied list
#' @param   x
#' @param   val
#' @return  list
#' @noRd
insertAt <- function(index.base, index.insert, side = "pre") {
  if (!side %in% c("pre", "post")) { # Integrity Checks
    stop("side must be a a string. It can take the values 'pre' or 'post'")
  }
  res <- list(index.base = index.base, index.insert = index.insert)
  for (i in seq_along(index.insert)) {
    at <- index.insert[i]
    if (side == "pre") { # VOR der benannten Position at einfügen
      index.base <- index.base + (index.base >= at) # Alle Indizes größer-gleich at werden um eines erhöht
      options(warn = -1) # in case index.base=numeric(0) warnings gets generated at max()
      index.insert <- index.insert + ((index.insert > at) &
        any(index.insert[seq_along(index.insert) > i] <= max(index.base)))
      options(warn = 0)
    }
    if (side == "post") { # NACH der benannten Position at einfügen
      index.base <- index.base + (index.base > at) # Alle Indizes größer als at werden um eines erhöht
      options(warn = -1) # in case index.base=numeric(0) warnings gets generated at max()
      index.insert <- index.insert + ((index.insert >= at) &
        any(index.insert[seq_along(index.insert) >= i] <= max(index.base)))
      options(warn = 0)
    }
  }
  c(res, list(index.base.new = index.base, index.insert.new = index.insert))
}



# insertAt(1:4, c(1,3))
# insertAt(c(1,2,3,4), c(1,3), side="pre")
# insertAt(c(1,2,3,4), c(1,2), side="pre")
# insertAt(c(1,2,3,4), c(4,5), side="pre")
# insertAt(c(1,2,3,4), c(5,6), side="pre")
# insertAt(c(1,2,3,4), c(1,2,3,5,6), side="pre")
# insertAt(1:4, 5:8)
# insertAt(numeric(0), 1:2)
# insertAt(numeric(0), c(1,3))

# insertAt(c(1,2,3,4), c(1,3), side="post")
# insertAt(c(1,2,3,4), c(1,2), side="post")
# insertAt(c(1,2,3,4), c(4,5), side="post")
# insertAt(c(1,2,3,4), c(5,6), side="post")
# insertAt(c(1,2,3,4), c(1,2,3,5,6), side="post")
# insertAt(1:4, 5:8, side="post")
# insertAt(numeric(0), 1:2, side="post")
# insertAt(numeric(0), c(1,3), side="post")



# There was once question on r-help asking if apply could be used with a progress bar.
# The plyr package provides several apply like functions also including progress bars,
# so one could have a look here and use a plyr function instead of apply if possible.
# Anyway, here comes a wrapper for apply/lapply that has a progressbar.

# Here is a wrapper for a function passed to apply that will create a text progress bar

# STATUS: WOKRING, but only tested once or twice, tested with ?apply examples
# ISSUES/TODO: MARGIN argument not always correct when vector like c(1,2) is used





#' apply with a progress bar
#'
#' Can be used like standard base:::apply. The only thing
#' it does is create an additional progress bar.
#'
#' @param X         see ?apply for parameter explanation
#' @param MARGIN    see ?apply
#' @param FUN       see ?apply
#' @param ...       see ?apply
#' @return    see ?apply
#' @seealso   [apply()]
#' @export
#' @keywords        internal
#' @examples \dontrun{
#'
#' apply_pb(anscombe, 2, sd, na.rm = TRUE)
#'
#' # larger dataset
#' df <- data.frame(rnorm(30000), rnorm(30000))
#' head(apply_pb(df, 1, sd))
#'
#' # performance comparison
#' df <- data.frame(rnorm(90000), rnorm(90000))
#' system.time(apply(df, 1, sd))
#' system.time(apply_pb(df, 1, sd))
#' }
#'
apply_pb <- function(X, MARGIN, FUN, ...) {
  env <- environment() # this environment
  pb_Total <- sum(dim(X)[MARGIN]) # get mex value for progress bar
  counter <- 0 # make counter variable
  pb <- txtProgressBar(min = 0, max = pb_Total, style = 3) # make progress bar

  # wrapper around FUN
  wrapper <- function(...) {
    curVal <- get("counter", envir = env) # get counter value
    assign("counter", curVal + 1, envir = env) # and increment it by one
    setTxtProgressBar(get("pb", envir = env), curVal + 1) # update progress bar
    FUN(...)
  }
  res <- apply(X, MARGIN, wrapper, ...) # apply wrapper with apply
  close(pb) # close progress bar
  res
}

# apply_pb(anscombe, 2, sd, na.rm=TRUE)

# large dataset
# df <- data.frame(rnorm(30000), rnorm(30000))
# head(apply_pb(df, 1, sd))



#' lapply with a progress bar
#'
#' Can be used like standard base:::lapply. The only thing
#' it does is create an additional progress bar.
#'
#' @param X           see ?lapply for parameter explanation
#' @param FUN         see ?lapply
#' @param ...         see ?lapply
#' @return list       see ?lapply
#' @seealso  [lapply()]
#' @export
#' @keywords          internal
#' @examples \dontrun{
#'
#' l <- sapply(1:20000, function(x) list(rnorm(1000)))
#' lapply_pb(l, mean)
#' }
#'
lapply_pb <- function(X, FUN, ...) {
  env <- environment() # this environment
  pb_Total <- length(X) # get max value for progress bar
  counter <- 0 # make counter variable
  pb <- txtProgressBar(min = 0, max = pb_Total, style = 3) # make progress bar

  # wrapper around FUN
  wrapper <- function(...) {
    curVal <- get("counter", envir = env) # get counter value
    assign("counter", curVal + 1, envir = env) # and increment it by one
    setTxtProgressBar(get("pb", envir = env), curVal + 1) # update progress bar
    FUN(...)
  }
  res <- lapply(X, wrapper, ...) # use wrapper with lapply
  close(pb) # close progress bar
  res
}

# l <- lapply(1:20000, function(x) list(rnorm(1000)))
# head(lapply_pb(l, mean))



#' sapply with a progress bar
#'
#' Can be used like standard base:::sapply. The only thing
#' it does is create an additional progress bar.
#'
#' @param X           see ?sapply for parameter explanation
#' @param FUN         see ?sapply
#' @param ...         see ?sapply
#' @return list       see ?sapply
#' @seealso  [sapply()]
#' @export
#' @keywords          internal
#' @examples \dontrun{
#'
#' l <- sapply(1:20000, function(x) list(rnorm(1000)))
#' head(sapply_pb(l, mean))
#'
#' # performance comparison
#' l <- sapply(1:20000, function(x) list(rnorm(1000)))
#' system.time(sapply(l, mean))
#' system.time(sapply_pb(l, mean))
#' }
sapply_pb <- function(X, FUN, ...) {
  env <- environment() # this environment
  pb_Total <- length(X) # get max value for progress bar
  counter <- 0 # make counter variable
  pb <- txtProgressBar(min = 0, max = pb_Total, style = 3) # make progress bar

  # wrapper around FUN
  wrapper <- function(...) {
    curVal <- get("counter", envir = env) # get counter value
    assign("counter", curVal + 1, envir = env) # and increment it by one
    setTxtProgressBar(get("pb", envir = env), curVal + 1) # update progress bar
    FUN(...)
  }
  res <- sapply(X, wrapper, ...) # use wrapper with sapply
  close(pb) # close progress bar
  res
}


#' reverse a string
#'
#' reverses the strings of a vector, i.e. c("ABC", "abc")
#' becomes c("CBA", "cba")
#'
#' @param x   a string or a vector of strings
#' @return vector  a string or vector of strings with reversed chars
#' @export
#' @keywords internal
#' @examples
#' strReverse(c("ABC", "abc"))
strReverse <- function(x) {
  sapply(lapply(strsplit(x, NULL), rev),
    paste,
    collapse = ""
  )
}


#' trim vector to lower or upper value
#'
#' the range a value may take is restricted to by an upper and
#' lower boundary. If it exceeds the boundary the value is replaced
#' by the boundary value or alternatively by NA
#'
#' @param x         numeric vector
#' @param minmax    minimal and maximal possible value (default c(-Inf, Inf)
#'                  i.e. no trimming occurs)
#' @param na        Use NAs for replacing values that are out of range
#' @return vector   vector whose elements that are out of range are replaced
#' @export
#' @keywords internal
#' @examples
#' trim_val(30)
#' trim_val(30, c(10, 20))
#'
trim_val <- function(x, minmax = c(-Inf, Inf), na = FALSE) {
  if (na) {
    x[x < minmax[1]] <- NA
    x[x > minmax[2]] <- NA
  } else {
    x[x < minmax[1]] <- minmax[1]
    x[x > minmax[2]] <- minmax[2]
  }
  x
}




#' recycle vector to given length
#'
#' @param vec       vector to be recycled
#' @param length    integer or vector. integer determines length of
#'                  recycling. If a vector is provided the length of the
#'                  vector is used.
#' @param na.fill   Use NAs for filling up to given length (default=FALSE)
#' @return vector
#' @note If 2nd argument is a vector, the first argument is recycled
#' to the length of the second vector. Instead of recycling the vector can
#' also be added extra NAs if the length argument is smaller than the
#' number of elements from vec, vec is cut off to make it usable for
#' many purposes.
#'
#' @export
#' @keywords internal
#' @examples
#' recycle(c(1, 2, 3), 7)
#' recycle(c(1, 2, 3), letters[1:7])
#' recycle(c(1, 2, 3), 7, na.fill = TRUE)
#' recycle(1, letters[1:3], na.fill = TRUE)
#' recycle(letters[1:3], 7)
#' recycle(letters[1:3], letters[1:7])
#' recycle(letters[1:40], letters[1:7]) # vec is cut off
recycle <- function(vec, length, na.fill = FALSE) {
  if (!is.vector(vec) & !is.vector(length)) {
    stop("vec and length must be vectors. length may also be an integer")
  }
  if (!is.numeric(length) & is.vector(length)) { # both vectors
    length <- length(length)
  }
  if (is.vector(length) & length(length) > 1L) { # is length a vector longer than 1
    length <- length(length)
  } # then get length of vector
  if (!na.fill) {
    newvec <- rep(vec, ceiling(length / length(vec))) # enlarge vector by recycling
  } else {
    newvec <- c(vec, rep(NA, length *
      (ceiling(length / length(vec)) - 1L))) # fill up with NAs
  }
  newvec[1L:length]
}



#' variation of recycle that recycles one vector x or y to the length of the
#' longer one
#'
#'
#' @param x         vector to be recycled if shorter than y
#' @param y         vector to be recycled if shorter than x
#' @param na.fill   Use NAs for filling up to given length (default=FALSE)
#' @return list     a list containing the recycled x vector as first and
#'                  the recycled y vector as second element
#' @export
#' @keywords internal
#' @examples
#' recycle2(1:10, 1:3)
#' recycle2(1, 1:5)
#' recycle2(1, 1:5, na.fill = TRUE)
#' recycle2(1:5, 5:1) # vectors unchanged
recycle2 <- function(x, y, na.fill = FALSE) {
  len.x <- length(x)
  len.y <- length(y)
  if (len.x < len.y) {
    x <- recycle(x, len.y, na.fill)
  } else if (len.x > len.y) {
    y <- recycle(y, len.x, na.fill)
  }
  list(x = x, y = y)
}




#' generate a random words
#'
#' randomWords generates a vector of random words taken from a small
#' set of words
#' @param n number of words to be generated (integer)
#' @return a string with n words (if length is not constrained)
#' @export
#' @keywords internal
#' @examples
#' randomWords(10) # 10 random words
randomWords <- function(n) {
  if (!is.numeric(n)) {
    stop("n must be an integer")
  }
  words <- c(
    "the", "novel", "depicts", "Harry", "as", "an", "essentially",
    "good", "man", "who", "is", "forced", "into", "blackmarket",
    "activity", "by", "economic", "forces", "beyond", "his",
    "control", "initially", "his", "fishing", "charter",
    "customer", "Mr.", "Johnson", "tricks", "Mark", "by",
    "slipping", "away", "without", "paying", "any", "of", "the",
    "money", "he", "owes", "him", "Brownstone", "then", "flees",
    "back", "to", "the", "mainland", "by", "airplane", "before",
    "he", "realizes", "what", "has", "happened", "I", "she"
  )
  sample(words, n, replace = TRUE)
}


#' generate a random sentence with n words
#'
#' @param n   number of word in sentence
#' @param maxchar   maximal number of characters per sentence. Note that whole
#'                  words (not part of words) are excluded if the maximal number
#'                   is exceeded.
#' @return a string with n words (if length is not constrained)
#' @export
#' @keywords internal
#' @examples
#' randomSentence(10) # one random sentence with 10 words
randomSentence <- function(n, maxchar = Inf) {
  x <- paste(randomWords(n), collapse = " ")
  x.split <- strsplit(x, " ")[[1]]
  chars <- as.vector(sapply(x.split, nchar))
  paste(unlist(x.split[cumsum(chars) < maxchar]), collapse = " ")
}


#' generate n random sentences with a given or random number of words
#'
#' @param n         number of sentences to be generate (integer)
#' @param nwords    number of words per sentence. If vector each sentence
#'           lengths is randomly drawn from the vector
#' @param maxchar   maximal number of characters per sentence. Note that whole
#'           words (not part of words) are excluded if the maximal number
#'          is exceeded.
#' @return a vector with n random sentences
#' @export
#' @keywords internal
#' @examples
#' randomSentences(5, 10) # five random sentences with ten words each
#' randomSentences(5, 2:10) # five random sentences between two and ten words
randomSentences <- function(n, nwords, maxchar = Inf) {
  sapply(sample(nwords, n, replace = TRUE),
    randomSentence,
    maxchar = maxchar
  )
}


#' find the order of a string vector so it will match the order of another
#'
#' @param x   a vector of strings
#' @param y   a vector of strings
#' @return  a vector of strings
#' @export
#' @keywords internal
#' @examples \dontrun{
#' a <- c("c", "a", "b")
#' b <- c("b", "c", "a")
#' index <- orderByString(a, b) # to order b like a needs what indexes?
#' index
#' b[index]
#' }
#'
orderByString <- function(x, y) {
  if (!all(x %in% y)) {
    stop("vector x and y do not contain the same (differently ordered) elements")
  }
  index <- order(order(x)) # reconversion index from sorted to old order
  order(y)[index]
}



### Thanks to Marc Schwartz for supplying the code for the Somer's d measure

# Calculate Concordant Pairs in a table
# cycle through x[r, c] and multiply by
# sum(x elements below and to the right of x[r, c])
# x = table
concordant <- function(x) {
  x <- matrix(as.numeric(x), dim(x))

  # get sum(matrix values > r AND > c)
  # for each matrix[r, c]
  mat.lr <- function(r, c) {
    lr <- x[(r.x > r) & (c.x > c)]
    sum(lr)
  }

  # get row and column index for each
  # matrix element
  r.x <- row(x)
  c.x <- col(x)

  # return the sum of each matrix[r, c] * sums
  # using mapply to sequence thru each matrix[r, c]
  sum(x * mapply(mat.lr, r = r.x, c = c.x))
}

# Calculate DIScordant Pairs in a table
# cycle through x[r, c] and multiply by
# sum(x elements below and to the left of x[r, c])
# x = table
discordant <- function(x) {
  x <- matrix(as.numeric(x), dim(x))

  # get sum(matrix values > r AND < c)
  # for each matrix[r, c]
  mat.ll <- function(r, c) {
    ll <- x[(r.x > r) & (c.x < c)]
    sum(ll)
  }

  # get row and column index for each
  # matrix element
  r.x <- row(x)
  c.x <- col(x)

  # return the sum of each matrix[r, c] * sums
  # using mapply to sequence thru each matrix[r, c]
  sum(x * mapply(mat.ll, r = r.x, c = c.x))
}


# Calculate Somers' d
# Return 3 values:
# 1. Sd C~R
# 2. Sd R~C
# 3. Sd Symmetric (Mean of above)
# x = table
calc.Sd <- function(x) {
  x <- matrix(as.numeric(x), dim(x))

  c <- concordant(x)
  d <- discordant(x)
  n <- sum(x)
  SumR <- rowSums(x)
  SumC <- colSums(x)

  Sd.CR <- (2 * (c - d)) / ((n^2) - (sum(SumR^2)))
  Sd.RC <- (2 * (c - d)) / ((n^2) - (sum(SumC^2)))
  Sd.S <- (2 * (c - d)) / ((n^2) - (((sum(SumR^2)) + (sum(SumC^2))) / 2))

  Sdlist <- list(Sd.CR, Sd.RC, Sd.S)
  names(Sdlist) <- c("Sd.CR", "Sd.RC", "Sd.S")

  Sdlist
}

## example from Kaehler book, p.123 table, p.129 results
# m <- matrix(c(4,6,0,11,146,22,2,20,39), 3)
# calc.Sd(m)    # correct



# ellipse and angle code from: Dr P.D.M. Macdonald
# http://www.math.mcmaster.ca/peter/s4c03/s4c03_0506/classnotes/DrawingEllipsesinR.pdf

# draw an ellipse
#
#
ellipse <- function(hlaxa = 1, hlaxb = 1, theta = 0, xc = 0, yc = 0,
                    newplot = F, npoints = 100, ...) {
  a <- seq(0, 2 * pi, length = npoints + 1)
  x <- hlaxa * cos(a)
  y <- hlaxb * sin(a)
  alpha <- angle(x, y)
  rad <- sqrt(x^2 + y^2)
  xp <- rad * cos(alpha + theta) + xc
  yp <- rad * sin(alpha + theta) + yc
  if (newplot) {
    plot(xp, yp, type = "l", ...)
  } else {
    lines(xp, yp, ...)
  }
  invisible()
}

angle <- function(x, y) {
  angle2 <- function(xy) {
    x <- xy[1]
    y <- xy[2]
    if (x > 0) {
      atan(y / x)
    } else {
      if (x < 0 & y != 0) {
        atan(y / x) + sign(y) * pi
      } else {
        if (x < 0 & y == 0) {
          pi
        } else {
          if (y != 0) {
            (sign(y) * pi) / 2
          } else {
            NA
          }
        }
      }
    }
  }
  apply(cbind(x, y), 1, angle2)
}


# //////////////////////////////////////////////////////////////////////////////
###                           FORMATTING                                   ####
# //////////////////////////////////////////////////////////////////////////////

#' Format a matrix and add index column.
#'
#' @param x         A matrix object.
#' @param rnames    Row names.
#' @param cnames    Column names.
#' @param pre.index Whether to make index prefix for rows and column names.
#' @param indexcol  Whether to make an index column.
#' @param diag      Whether to show diagonal.
#' @param mode      Whether to show upper (mode=1), lower (mode=2)
#'                  or both triangles (mode=0) of the matrix.
#' @keywords        internal
#' @export
#'
formatMatrix <- function(x, rnames = rownames(x), pre.index = c(T, F),
                         cnames = seq_len(ncol(x)), indexcol = F, digits = 2,
                         diag = F, mode = 1) {
  blanks <- paste(rep(" ", digits + 2), collapse = "")
  if (mode == 1) {
    x[lower.tri(x, diag = !diag)] <- blanks
  }
  if (mode == 2) {
    x[upper.tri(x, diag = !diag)] <- blanks
  }

  if (pre.index[1]) {
    rnames <- paste(seq_len(nrow(x)), rnames)
  }
  if (pre.index[2]) {
    cnames <- paste(seq_len(ncol(x)), cnames)
  }
  if (indexcol) {
    rownames(x) <- rnames
    x <- addIndexColumnToMatrix(x)
  } else {
    rownames(x) <- rnames
    colnames(x) <- cnames
  }
  x
}


# add names to columns and rows and do trimming
# along 1=constructs, 2=elements
#
addNamesToMatrix <- function(x, m, trim = 7, along = 1) {
  if (!inherits(x, "repgrid")) { # check if x is repgrid object
    stop("Object x must be of class 'repgrid'")
  }
  if (along == 1) {
    cnamesl <- constructs(x)$leftpole
    cnamesr <- constructs(x)$rightpole
    new.names <- paste(cnamesl, cnamesr, sep = " - ")
  } else {
    new.names <- elements(x)
  }
  if (!is.na(trim)) { # trim constructs if prompted
    new.names <- substr(new.names, 1, trim)
  }
  rownames(m) <- colnames(m) <- new.names # assign new names to row and column names
  m
}

# new version using helper functions
# add names to columns and rows and do trimming
# along 1=constructs, 2=elements
#
addNamesToMatrix2 <- function(x, m, index = F, trim = 7, along = 1) {
  if (!inherits(x, "repgrid")) { # check if x is repgrid object
    stop("Object x must be of class 'repgrid'")
  }
  if (along == 1) {
    new.names <- getConstructNames2(x, index = index, trim = trim)
  } else {
    new.names <- getElementNames2(x, index = index, trim = trim)
  }
  rownames(m) <- colnames(m) <- new.names # assign new names to row and column names
  m
}

#' add index column for neater colnames
#'
#'
#' @param x   `matrix` object
#' @export
#' @keywords internal
#' @examples \dontrun{
#' x <- matrix(1:9, 3)
#' colnames(x) <- rep("Long names that occupiy too much space", 3)
#' rownames(x) <- rep("Some text", 3)
#' addIndexColumnToMatrix(x)
#' }
#'
addIndexColumnToMatrix <- function(x) {
  if (dim(x)[1] != dim(x)[2]) {
    stop("works for square matrices only")
  }
  indexes <- 1L:dim(x)[1]
  res <- cbind(indexes, x)
  colnames(res) <- c(" ", indexes)
  res
}


#' Density histogram with steps instead of bars.
#'
#' Make a histogram with steps instead of bars. Densities are used
#' for the heights.
#'
#' @param vals      Numeric values to display.
#' @param breaks    Passed on to `hist`.
#'                  See `?hist` parameter `breaks` for more information.
#' @param add       Whether to add the steps to an existing plot (`FALSE`)
#'                  or to create a new plot (default `add = TRUE`).
#' @export
#' @keywords        internal
#' @examples \dontrun{
#' x <- rnorm(1000)
#' y <- rnorm(1000, sd = .6)
#' stepChart(y, breaks = 50)
#' stepChart(x, add = T, breaks = 50, col = "red")
#' }
#'
stepChart <- function(vals, breaks = "Sturges", add = FALSE, ...) {
  h <- hist(vals, breaks = breaks, plot = F)
  x <- h$breaks
  y <- h$density
  x <- c(x, x[length(x)])
  y <- c(0, y, 0)
  if (add) {
    points(x, y, type = "s", ...)
  } else {
    plot(x, y, type = "s", ...)
  }
}


list_to_dataframe <- function(l) {
  # plyr:::list_to_dataframe(l)
  do.call(rbind.data.frame, l)
}