R/repgrid-elements.r

In markheckmann/OpenRepGrid: Tools to Analyze Repertory Grid Data

#----------------------------------------------#
### 				basic element operations				 ###
#----------------------------------------------#

# Function that start with e. operate on the elements only.
# These functions serve for basic operations on elements.
# In case a function needs to operate on elements and other
# slots (e.g. constructs, ratings) higher-level functions
# that perform joints operations are used. The base operations
# are not needed when using openrepgrid. Only in case the user wants to
# create new functions they will be needed.

### basic functions:
# ------------------------- #
# add elements
# delete elements
# rename elements (full and abbreviated names)
# set elememt status (ideal)
# change element order


##############   FUNCTIONS TO RETRIEVE INFORMATION FROM REPGRID OBJECTS   ##################

# internal: retrieve element slot. For convenience, so new users do not have to deal with object slots
# as they will not have knowledge of object structures (S3, S4).
getElements <- function(x) {
  if (!inherits(x, "repgrid")) { # check if x is repgrid object
    stop("Object x must be of class 'repgrid'.")
  }
  x@elements
}


#' Retrieve element names of repgrid object.
#'
#' Function for convenience, so new users do not have to deal with object slots
#' as they will typically not have knowledge about R object structures (S3, S4).
#'
#' @param x `repgrid` object.
#' @return vector Vector containing the names of the elements.
#' @section Deprecated functions: `getElementNames()`,
#'   `getElementNames2()`, and `eNames()` have been deprecated.
#'   Instead use `elements()`.
#' @export
#' @keywords internal
#'
getElementNames <- function(x) {
  if (!inherits(x, "repgrid")) { # check if x is repgrid object
    stop("Object x must be of class 'repgrid'.")
  }

  .Deprecated("elements")

  sapply(x@elements, function(x) x$name)
}
eNames <- getElementNames

## sample code
# rg1 <- makeEmptyRepgrid()
# rg1 <- setElements(rg1, LETTERS[1:5])
# getElements(rg1)
# getElementNames(rg1)




#' Retrieves the element names from a `repgrid`.
#'
#' Different features like trimming, indexing and choices of separators
#' allow to return the kind of format that is needed.
#'
#' @title Retrieve element names in needed format.
#'
#' @param x       `repgrid` object.
#' @param trim    Number of characters to trim the construct names to
#'                (default `NA`). `NA` will suppress trimming.
#'                The length of `index` is not included in the
#'                trimming.
#' @param index   Logical. Whether to add a index number before the construct
#'                names (default `TRUE`).
#' @param pre     String before index number (default `(`).
#' @param post    String after index number (default `) `).
#' @return  Vector with (trimmed) element names.
#' @export
#' @keywords internal
#' @examples \dontrun{
#'
#' getElementNames2(bell2010)
#' getElementNames2(bell2010, mode = 2)
#' getElementNames2(bell2010, index = T)
#' getElementNames2(bell2010, index = T, trim = 30)
#' }
#'
getElementNames2 <- function(x, trim = 20, index = F,
                             pre = "(", post = ") ") {
  if (!inherits(x, "repgrid")) {
    stop("Object x must be of class 'repgrid'")
  }

  enames <- elements(x)

  # add numeric index in front of elements
  if (index) {
    ind <- paste(pre, seq_along(enames), post, sep = "")
  } else {
    ind <- ""
  }

  # trim names if prompted
  if (!is.na(trim)) {
    enames <- substr(enames, 1, trim)
  }

  enames.new <- paste(ind, enames, sep = "")
  enames.new
}




#' Get or replace element names
#'
#' Allows to get and set element names.
#' Replaces the older functions `getElementNames`, `getElementNames2`,
#' and `eNames` which are deprecated.
#'
#' @param  x A repgrid object.
#' @rdname elements
#' @export
#' @examples
#'
#' # copy Boeker grid to x
#' x <- boeker
#'
#' ## get element names
#' e <- elements(x)
#' e
#'
#' ## replace element names
#' elements(x) <- rev(e) # reverse all element names
#' elements(x)[1] <- "Hannes" # replace name of first element
#'
#' # replace names of elements 1 and 3
#' elements(x)[c(1, 3)] <- c("element 1", "element 3")
#'
elements <- function(x) {
  # check if x is a repgrid object
  if (!inherits(x, "repgrid")) {
    stop("Object x must be of class 'repgrid'.")
  }

  # get name property from each element
  sapply(x@elements, function(x) x$name)
}


#' @param position Index where to insert element.
#' @param value Character vector of element names.
#' @rdname elements
#' @export
#'
`elements<-` <- function(x, position, value) {
  # check if x is a repgrid object
  if (!inherits(x, "repgrid")) {
    stop("Object x must be of class 'repgrid'.")
  }

  # get element names and replace one or more
  e.names <- elements(x)
  e.names[position] <- value

  # replace name propert of each element
  for (i in seq_along(e.names)) {
    x@elements[[i]]$name <- e.names[i]
  }

  x
}


getNoOfElements <- function(x) {
  if (!inherits(x, "repgrid")) { # check if x is repgrid object
    stop("Object x must be of class 'repgrid'.")
  }
  length(x@elements)
}
# getNoOfElements(rg1)


# internal: e.makeNewElement makes a new element object which is simply list with certain standard
# entries
e.makeNewElement <- function(x = NULL, name = NA, abbreviation = NA, status = NA) {
  list(
    name = name,
    abbreviation = abbreviation,
    status = status
  )
}


# internal: e.setElements sets one or more elements in the grid. The index defines the column where the
# element is added.
e.setElements <- function(x, name = NA, abbreviation = NA, status = NA, index = NULL, ...) {
  if (!inherits(x, "repgrid")) { # check if x is repgrid object
    stop("Object x must be of class 'repgrid'.")
  }
  if (!is.atomic(name) | !is.atomic(abbreviation) | !is.atomic(status)) { # if elements comes as a vector
    stop("arguments name, abbreviation and status must be a vector")
  }
  if (is.null(index)) {
    index <- seq_len(max(c(length(name), length(abbreviation), length(status))))
  }
  if (length(index) != max(c(length(name), length(abbreviation), length(status)))) {
    stop("length of index values differ from number of elements provided.")
  }
  if (length(unique(index)) != length(index)) { # is index unique?
    stop("index values must be unique.")
  }
  new.elements <- index[index > length(x@elements)] # elements that are replaced
  replaced.elements <- index[index <= length(x@elements)] # elements that are added
  if (max(index) > (length(x@elements) + length(new.elements))) { # wholes in element list if added at an index that is not succesive (e.g. 1,2,5)?
    stop("index has values that will create wholes in the element list.")
  }
  if (!(is.na(name[1]) & is.na(abbreviation[1]) & is.na(status[1]))) {
    newElements <- mapply(e.makeNewElement, "dummy", name = name, abb = abbreviation, status = status, SIMPLIFY = FALSE) # generate new element list
    x@elements[index] <- newElements
  }
  # add no of columns in ratings array if element is added: TODO? -> in higher-order function in repgrid-basicops
  x
}
#  x <- makeEmptyRepgrid()
#  x <- e.setElements(x, name=c("element 1", "element 2"), abb=c("e1","e2"), i=2:1)
#  x <- e.setElements(x, name=c("element 3", "element 4"), abb=c("e3","e4"), index=3:4)
#  x <- makeEmptyRepgrid()
#  x <- e.setElements(x, name="test")
#  x <- e.setElements(x, name="test", index=3)  # error due to wholes in element list



# internal: e.addElements adds elements to the grid. All elements that do not have
# a position specified are added at the end.
e.addElements <- function(x, name = NA, abbreviation = NA, status = NA, position = NA, side = "pre") {
  if (!inherits(x, "repgrid")) { # check if x is repgrid object
    stop("Object x must be of class 'repgrid'.")
  }
  if (!is.numeric(position) & !(length(position) == 1 & is.na(position[1]))) {
    stop("position must be numeric.")
  }
  len <- max(c(length(name), length(abbreviation), length(status)))
  if (length(position) == 1 & is.na(position[1])) {
    position <- rep(NA, len)
  }
  if (length(unique(position)) != length(position) & !all(is.na(position))) { # is index unique?
    stop("position values must be unique.")
  }
  position[is.na(position)] <- seq_along(position[is.na(position)]) + length(x@elements)
  elements.old <- x@elements
  elements.new <- mapply(e.makeNewElement, NA, name = name, abb = abbreviation, status = status, SIMPLIFY = FALSE) # generate new element list
  index <- insertAt(seq_along(x@elements), position, side = side)
  tmp <- c(index$index.base.new, index$index.insert.new)
  if (max(tmp) > length(tmp)) {
    stop("position has values that will create wholes in the element list.")
  }
  x@elements[index$index.base.new] <- elements.old[index$index.base]
  x@elements[index$index.insert.new] <- elements.new
  x
}
### NOT RUN
# x <- makeEmptyRepgrid()
# x <- e.setElements(x, name=c("element 1", "element 2"), abb=c("e1","e2"))
# x <- e.addElements(x, name="element added at the end")
# x <- e.addElements(x, name="element inserted at position 1", pos=1)
# x <- e.addElements(x, name=c("element A", "element B"), abb=c("e1","e2"), pos=5:6)
# x <- e.addElements(x, name=c("element A", "element B"), abb=c("e1","e2"), pos=10:11)
# x <- e.addElements(x, name=c("element C", "element D"), abb=c("eA","eB"), pos=c(1,1))  # todo geht nicht

# x <- makeEmptyRepgrid()
# x <- addElements(x, name=c("element 1", "element 2"), abb=c("e1","e2"))
# insertAt(numeric(0), 1:2)










### maybe unnecessary functions ###

# internal: e.removeNullElements removes non exsiting elements
# TODO: might already be unnecessary as NULL elements should not be allowed
# e.removeNullElements <- function(x){
#   if(!inherits(x, "repgrid"))               # check if x is repgrid object
#     stop("Object x must be of class 'repgrid'.")
#   x@elements <- x@elements[!sapply(x@elements, is.null)]
#   x
# }

# internal: e.deleteElements to delete specific element
# e.deleteElements <- function(x, pos){
#   if(!inherits(x, "repgrid"))               # check if x is repgrid object
#     stop("Object x must be of class 'repgrid'.")
#   if(any(pos<0 | pos > getNoOfElements(x)))
#     stop("pos must contain values greater than 1 and equal or less than number of elements.")
#   x@elements <- x@elements[-pos]
#   x
# }
# x <- makeEmptyRepgrid()
# x <- addElements(x, name=c("element 1", "element 2"), abb=c("e1","e2"))
# str(x)
# x <- deleteElements(x, 1)
# str(x)