#-------------------------------------------------------------#
# basic operations on repgrid objects #
#-------------------------------------------------------------#
#' Test if object has class repgrid
#' @param x Any object.
#' @export
is.repgrid <- function(x) {
inherits(x, "repgrid")
}
#' Raise error if not is repgrid object
#' @param x Object to test. Raises an error if no `repgrid` object.
#' @param name Name of tested variable in error message.
#' @export
#' @keywords internal
#'
stop_if_not_is_repgrid <- function(x, name = "x") {
if (!is.repgrid(x)) {
stop("Object '", name, "' must have class 'repgrid'", call. = FALSE)
}
}
#' Raise error if repgrid object has ratings other than 0/1
#' @param x A `repgrid` object.
#' @param name Name of tested variable in error message.
#' @export
#' @keywords internal
#'
stop_if_not_0_1_ratings_only <- function(x, name = "x") {
r <- ratings(x)
ii <- r %in% 0:1
check <- all(ii)
if (!check) {
other_values <- sort(unique(r[!ii]))
msg <- paste(other_values, collapse = ",")
stop("Object '", name, "' must have 0/1 ratings only. Also found: ", msg, call. = FALSE)
}
}
#' Raise error if min or max of rating scale are undefined
#' @param x Object to test. Raises an error the mina and max of the ratings scale are not defined
#' @export
#' @keywords internal
#'
stop_if_scale_not_defined <- function(x) {
stop_if_not_is_repgrid(x, name)
if (identical(x@scale$min, NA) | identical(x@scale$min, NULL)) {
stop("No min value for the rating scale defined. To define the scale use setScale().")
}
if (identical(x@scale$max, NA) | identical(x@scale$max, NULL)) {
stop("No max value for the rating scale defined. To define the scale use setScale().")
}
}
############################# EXTRACT AND SET #################################
## S4 methods
# overloading primitive generic "[" getter
# "[" is supposed to function like always, i.e. positive integers for selection
# or reordering negative integers for deletion. These cannot be mixed
# TODO: ?keep single entry as row selection. Normally its column selection e.g.
# in data frames.
# aliases [,repgrid-method
# docType methods
#' Extract parts of the repgrid object.
#'
#' Methods for `"["`, i.e., subsetting of repgrid objects.
#'
#' @param x A `repgrid` object.
#' @param i,j Row and column indices.
#' @param ... Not evaluated.
#' @param drop Not used.
#' @rdname extract-methods
#' @aliases [,repgrid-method
#' @include repgrid.r
#' @examples
#'
#' x <- randomGrid()
#' x[1:4, ]
#' x[, 1:3]
#' x[1:4, 1:3]
#' x[1, 1]
#'
setMethod(
"[", signature(x = "repgrid", i = "ANY", j = "ANY"),
function(x, i, j, ..., drop) {
dots <- list(...)
if (length(dots) == 0) {
layer <- seq_along(dim(x@ratings)[3]) # 1:3
} else if (!is.numeric(dots[[1]])) {
stop("... must be numeric as it is third index for 3D-array.")
} else if (!any(dots[[1]] %in% 1:3)) {
stop("... must be an integer between from 1 to 3.")
} else {
layer <- dots[[1]]
}
if (missing(i)) {
i <- seq_len(length(x@constructs))
}
if (missing(j)) {
j <- seq_len(length(x@elements))
}
if (!is.numeric(c(i, j))) { # check if i,j are numeric
stop("All index values must be numeric")
}
if (any(is.na(c(i, j)))) {
stop("NA values are not allowed as indexes.")
}
if (!((all(i >= 0) | all(i <= 0)) & (all(j >= 0) | all(j <= 0)))) { # check if i and j are each only positive or only negative
stop(
"Negative and positive indexes for constructs/elements must not be mixed. ",
"A positive index will select an element/construct a negative one will delete it."
)
}
if (any(i > length(x@constructs)) | any(i == 0)) { # check if all indexes do not exceed numer of elements or constructs
stop(
"index for constructs is out of range. ",
"Index must not exceed the number of constructs or equal zero."
)
}
if (any(j > length(x@elements)) | any(j == 0)) { # check if all indexes do not exceed numer of elements or constructs
stop(
"index for elements is out of range. ",
"Index must not exceed the number of elements or equal zero."
)
}
x@constructs <- x@constructs[i]
x@elements <- x@elements[j]
x@ratings <- x@ratings[i, j, layer, drop = FALSE]
x
}
)
# aliases [<-,repgrid-method
# docType methods
# overloading primitive generic "[<-" setter.
#
#' Method for "<-" assignment of the repgrid ratings.
#'
#' It should be possible to use it for ratings on all layers.
#'
#' @param x A `repgrid` object.
#' @param i,j Row and column indices.
#' @param value Numeric replacement value(s).
#' @param ... Not evaluated.
#' @rdname subassign
#' @include repgrid.r
#' @examples \dontrun{
#' x <- randomGrid()
#' x[1, 1] <- 2
#' x[1, ] <- 4
#' x[, 2] <- 3
#'
#' # settings values outside defined rating scale
#' # range throws an error
#' x[1, 1] <- 999
#'
#' # removing scale range allows arbitary values to be set
#' x <- setScale(x, min = NA, max = NA)
#' x[1, 1] <- 999
#' }
#'
setMethod(
"[<-", signature(x = "repgrid", i = "ANY", j = "ANY", value = "ANY"),
function(x, i, j, ..., value) {
dots <- list(...)
if (length(dots) == 0) {
layer <- 1
} else if (!is.numeric(dots[[1]])) {
stop("... must be numeric as it is third index for 3D-array")
} else if (!any(dots[[1]] %in% 1:3)) {
stop("... must be an integer between from 1 to 3")
} else {
layer <- dots[[1]]
}
if (missing(i)) {
i <- seq_len(length(x@constructs))
}
if (missing(j)) {
j <- seq_len(length(x@elements))
}
if (!is.numeric(c(i, j))) { # check if i,j are numeric
stop("All index values must be numeric")
}
if (any(is.na(c(i, j)))) {
stop("NA values are not allowed as indexes")
}
if (!((all(i >= 0) | all(i <= 0)) & (all(j >= 0) | all(j <= 0)))) { # check if i and j are each only positive or only negative
stop(
"Negative and positive indexes for constructs/elements must not be mixed.",
" A positive index will select an element/construct a negative one will delete it"
)
}
if (any(i > length(x@constructs)) | any(i == 0)) { # check if all indexes do not exceed numer of elements or constructs
stop("index for constructs is out of range.", "
Index must not exceed the number of constructs or equal zero.")
}
if (any(j > length(x@elements)) | any(j == 0)) { # check if all indexes do not exceed numer of elements or constructs
stop(
"index for elements is out of range. Index must not",
" exceed the number of elements or equal zero."
)
}
# prevent values outside of scale range from being set
s <- getScale(x)
sn <- is.null(s) | any(is.na(s))
if ((!sn & (any(value < s[1]) | any(value > s[2])))) {
stop("Setting values outside of defined scale range is not allowed.",
" Use 'getScale' to see and 'setScale' to define the scale range. ",
call. = FALSE
)
}
x@ratings[i, j, layer] <- value
# to fill by rows
# as.vector(matrix(as.vector(value), ncol=length(x@elements), byrow=TRUE))
# another idea to fill by rows by transposing the part of importance
# f <- t(d[1:3, 1:2])
# f[,] <- 1:6
# d[1:3, 1:2] <- t(f)
x
}
)
########################### GETTER AND SETTER ###############################
#' get rating layer
#'
#' @param x `repgrid` object.
#' @param layer layer to be returned.
#' @param names extract row and columns names (constructs and elements).
#' @param trim the number of characters a row or column name is trimmed to
#' (default is `10`). If `NA` no trimming is done. Trimming
#' simply saves space when displaying the output.
#' @return a `matrix`
#'
#' @export
#' @keywords internal
#' @examples \dontrun{
#'
#' getRatingLayer(bell2010)
#' }
#'
getRatingLayer <- function(x, layer = 1, names = TRUE, trim = 10) {
scores <- x@ratings[, , layer, drop = FALSE] # select layer
rm <- apply(scores, 2, I) # convert array to matrix
if (names) {
cnames.l <- constructs(x)$leftpole
cnames.r <- constructs(x)$rightpole
enames <- elements(x)
if (!is.na(trim)) { # trim names if prompted
cnames.l <- substr(cnames.l, 1, trim)
cnames.r <- substr(cnames.r, 1, trim)
enames <- substr(enames, 1, trim)
}
rownames(rm) <- paste(cnames.l, cnames.r, sep = " - ")
colnames(rm) <- enames
}
rm
}
# 'ratings' function replaces 'getRatingLayer'
# as it sounds simpler
#' Extract ratings (wide or long format)
#'
#' @param x A `repgrid` object.
#' @param names Extract row and columns names (constructs and elements).
#' @param trim The number of characters a row or column name is trimmed to
#' (default is `10`). If `NA` no trimming is done. Trimming simply
#' saves space when displaying the output.
#' @param long Return as long format? (default `FALSE`)
#' @param i,j Row and column indices.
#' @param value Numeric replacement value(s).
#' @return A `matrix`.#'
#' @export
#' @rdname ratings
#' @seealso ``[<--method``
#' @examples
#'
#' ## store Bell's dataset in x
#' x <- bell2010
#'
#' ## get ratings
#' ratings(x)
#'
#'
#' ## replace ratings
#'
#' ratings(x)[1, 1] <- 1
#' # noet that this is even simpler using the repgrid object directly
#' x[1, 1] <- 2
#'
#' # replace several values
#'
#' ratings(x)[1, 1:5] <- 1
#' x[1, 1:5] <- 2 # the same
#'
#' ratings(x)[1:3, 5:6] <- matrix(5, 3, 2)
#' x[1:3, 5:6] <- matrix(5, 3, 2) # the same
#'
#'
#' ## ratings as dataframe in wide or long format
#'
#' ratings_df(x)
#' ratings_df(x, long = TRUE)
#'
ratings <- function(x, names = TRUE, trim = 10) {
layer <- 1 # get first layer of ratings array. The other two are not used
scores <- x@ratings[, , layer, drop = FALSE] # select layer
rm <- apply(scores, 2, I) # convert array to matrix
if (names) {
cnames.l <- constructs(x)$leftpole
cnames.r <- constructs(x)$rightpole
enames <- elements(x)
if (!is.na(trim)) { # trim names if prompted
cnames.l <- substr(cnames.l, 1, trim)
cnames.r <- substr(cnames.r, 1, trim)
enames <- substr(enames, 1, trim)
}
rownames(rm) <- paste(cnames.l, cnames.r, sep = " - ")
colnames(rm) <- enames
}
rm
}
#' @export
#' @rdname ratings
ratings_df <- function(x, long = FALSE, names = TRUE, trim = NA) {
r <- ratings(x, trim = trim, names = names)
if (!names) {
colnames(r) <- paste0("E", 1L:ncol(x))
}
r <- as.data.frame(r)
nc <- nrow(r)
cn <- constructs(x)
ii <- data.frame(construct_index = 1L:nc)
df <- cbind(ii, cn, r)
rownames(df) <- NULL
if (long) {
df <- tidyr::pivot_longer(df, cols = names(r), names_to = "element", values_to = "rating")
}
df
}
#' @rdname ratings
#' @export
`ratings<-` <- function(x, i, j, value) {
# check if x is a repgrid object
if (!inherits(x, "repgrid")) {
stop("Object x must be of class 'repgrid'.")
}
# fet rating matrix and replace values
r <- ratings(x)
r[i, j] <- value
# replace all ratings
x[, ] <- r
x
}
#' Get number of constructs
#'
#' @param x `repgrid` object
#' @return `numeric`
#'
#' @export
#' @keywords internal
#' @examples \dontrun{
#'
#' getNoOfConstructs(bell2010)
#' }
#'
getNoOfConstructs <- function(x) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("object x and y must be of class 'repgrid'")
}
length(x@constructs)
}
#' Get number of elements
#'
#' @param x `repgrid` object
#' @return `numeric`
#'
#' @export
#' @keywords internal
#' @examples \dontrun{
#'
#' getNoOfElements(bell2010)
#' }
#'
getNoOfElements <- function(x) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("object x and y must be of class 'repgrid'")
}
length(x@elements)
}
#' Set the scale range of a grid.
#'
#' The scale must be known for certain
#' operations, e.g. to swap the construct poles. If the user construes
#' a grid he should make sure that the scale range is set correctly.
#'
#' @param x `repgrid` object.
#' @param min Minimal possible scale value for ratings.
#' @param max Maximal possible scale value for ratings.
#' @param step Steps the scales uses (not yet in use).
#' @param ... Not evaluated.
#'
#' @return `repgrid` object
#' @export
#' @examples \dontrun{
#'
#' x <- bell2010
#' x <- setScale(x, 0, 8) # not set correctly
#' x
#' x <- setScale(x, 1, 7) # set correctly
#' x
#' }
#'
setScale <- function(x, min, max, step, ...) { # ... needes for makeRepgrid call
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("Object x must be of class 'repgrid'")
}
if (!missing(min)) {
if (any(x@ratings < min, na.rm = TRUE)) { # any rating value smaller than min?
stop(
"Some ratings are smaller than the min value you entered. ",
"The setting of the min value in the grid was not performed. ",
"Please check the ratings or choose another min value."
)
}
x@scale$min <- min
}
if (!missing(max)) {
if (any(x@ratings > max, na.rm = TRUE)) { # any rating value smaller than min?
stop(
"Some ratings are bigger than the max value you entered. ",
"The setting of the max value in the grid was not performed. ",
"Please check the ratings or choose another max value."
)
}
x@scale$max <- max
}
if (!missing(step)) {
x@scale$step <- step
}
x
}
# setScale(x, min=1, max=5, step=1)
#' Get minimum and maximum scale value used in grid.
#'
#' The values are returned either as a vector or a list.
#'
#' @param x `repgrid` object.
#' @param output Type of output object. 1= named vector, 2 = list.
#' @return Vector or list (depends on `output` containing
#' minimum and maximum scale value.
#' @keywords internal
#' @export
getScale <- function(x, output = 1) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("Object x must be of class 'repgrid'")
}
smin <- x@scale$min
smax <- x@scale$max
if (output == 1) {
res <- c(min = smin, max = smax)
} else if (output == 2) {
res <- list(min = smin, max = smax)
}
res
}
### TODO
#' setMeta
#'
#' set meta data of a grid (e.g. id, name of interview partner)
#'
#' @param x repgrid object
#' @param type type of grid in use (rating, ranked, implication)
#' @param id id of the interview
#' @param name name of the interview partner
#' @return `repgrid` object
#' @export
#' @keywords internal
#' @examples \dontrun{
#'
#' #### TODO ####
#' }
#'
setMeta <- function(x, type, id, name) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("Object x must be of class 'repgrid'")
}
if (!missing(type)) { # rating, rank or implication
x@meta$type <- type
}
if (!missing(name)) {
x@meta$id <- id
}
if (!missing(name)) {
x@meta$name <- name
}
x
}
# x <- setMeta(x, id=1, name="John Doe")
#' Get midpoint of the grid rating scale
#'
#' @param x `repgrid` object.
#' @return Midpoint of scale.
#'
#' @export
#' @keywords internal
#' @examples \dontrun{
#'
#' getScaleMidpoint(bell2010)
#' }
#'
getScaleMidpoint <- function(x) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("object x and y must be of class 'repgrid'")
}
(x@scale$max - x@scale$min) / 2 + x@scale$min
}
#' Midpoint of the grid rating scale
#'
#' @param x `repgrid` object.
#' @return Midpoint of scale.
#'
#' @export
#' @examples
#' midpoint(bell2010)
#'
midpoint <- getScaleMidpoint
############################# CHANGE POSITION ##############################
#' Swap the position of two elements in a grid.
#'
#' @param x `repgrid` object.
#' @param pos1 Column number of first element to be swapped (default=1).
#' @param pos2 Column number of second element to be swapped (default=1).
#'
#' @return `repgrid` object.
#' @export
#' @keywords internal
#' @examples \dontrun{
#' x <- randomGrid()
#' swapElements(x, 1, 3) # swap elements 1 and 3
#' swapElements(x, 1:2, 3:4) # swap element 1 with 3 and 2 with 4
#' }
#'
swapElements <- function(x, pos1 = 1, pos2 = 1) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("Object x must be of class 'repgrid'.")
}
if (any(c(pos1, pos2) < 0) | any(c(pos1, pos2) > length(x@elements))) {
stop("pos1 and pos2 must be bigger than 1 and have number of elements as a maximum")
}
if (any(c(pos1, pos2) < 0) | any(c(pos1, pos2) > ncol(x@ratings))) {
stop("pos1 and pos2 must be bigger than 1 and have number of elements as a maximum")
}
x@elements[c(pos1, pos2)] <- x@elements[c(pos2, pos1)]
x@ratings[, c(pos1, pos2), ] <- x@ratings[, c(pos2, pos1), ]
# x <- e.swopElementPosition(x, pos1=pos1, pos2=pos2)
# x <- r.swopRatingsColumns(x, pos1=pos1, pos2=pos2)
x
}
# @aliases swape
# swape <- swapElements # alias
# swopElements <- swapElements
# swopE <- swapElements
# swopElements(rg, 1,3)
#' Swap the position of two constructs in a grid.
#'
#' @param x `repgrid` object.
#' @param pos1 Row number of first construct to be swapped (default=1).
#' @param pos2 Row number of second construct to be swapped (default=1).
#' @return `repgrid` object
#' @export
#' @keywords internal
#' @rdname swapConstructs
#' @examples \dontrun{
#'
#' x <- randomGrid()
#' swapConstructs(x, 1, 3) # swap constructs 1 and 3
#' swapConstructs(x, 1:2, 3:4) # swap construct 1 with 3 and 2 with 4
#' }
#'
swapConstructs <- function(x, pos1 = 1, pos2 = 1) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("Object x must be of class 'repgrid'.")
}
if (any(c(pos1, pos2) < 0) | any(c(pos1, pos2) > nrow(x@ratings))) {
stop("pos1 and pos2 must be bigger than 1 and have number of constructs as a maximum")
}
x@constructs[c(pos1, pos2)] <- x@constructs[c(pos2, pos1)]
x@ratings[c(pos1, pos2), , ] <- x@ratings[c(pos2, pos1), , ]
# x <- c.swopConstructPosition(x, pos1=pos1, pos2=pos2)
# x <- r.swopRatingsRows(x, pos1=pos1, pos2=pos2)
x
}
# @aliases swapc
# swapc <- swapConstructs #alias
# swopConstructs <- swapConstructs
# swopC <- swapConstructs
# swopConstructs(rg, 1,2)
#' Reverse constructs / swaps construct poles
#'
#' Constructs are bipolar. They can be reversed without a change in meaning. The
#' function swaps the constructs poles and re-adjusts ratings accordingly, i.e.
#' it reversed selected constructs.
#'
#' @param x A `repgrid` object.
#' @param pos Row indexes of constructs to reverse..
#' @return A `repgrid` object with reversed constructs.
#' @note Please note that the scale of the rating grid has to be set in order
#' to reverse constructs. If the scale is unknown no reversal occurs and an
#' error is raised.
#' @export
#' @keywords internal
#' @rdname reverse
#' @examples
#'
#' x <- boeker
#'
#' reverse(x) # reverse all constructs
#' reverse(x, 1) # reverse construct 1
#' reverse(x, 1:2) # reverse constructs 1 and 2
#'
#' # swapPoles will become deprecated, use reverse instead
#' swapPoles(x, 1) # swap construct poles of construct
#'
swapPoles <- function(x, pos) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("Object x must be of class 'repgrid'")
}
if (missing(pos)) {
pos <- seq_along(x@constructs)
}
if (any(pos <= 0 | pos > getNoOfConstructs(x))) {
stop("pos must contains values greater than 0 and equal or less than number of constructs.")
}
if (identical(x@scale$min, NA) | identical(x@scale$min, NULL)) {
stop(
"A min value for the scale has to be defined in order to swap poles.",
"To define the scale use setScale(). For more info type ?setScale to the console."
)
}
if (identical(x@scale$max, NA) | identical(x@scale$max, NULL)) {
stop(
"A min value for the scale has to be defined in order to swap poles.",
"To define the scale use setScale(). For more info type ?setScale to the console."
)
}
# swap names of poles
for (i in pos) {
tmp <- x@constructs[[i]]$leftpole
x@constructs[[i]]$leftpole <- x@constructs[[i]]$rightpole
x@constructs[[i]]$rightpole <- tmp
}
# reverse ratings
nc <- ncol(x@ratings[pos, , , drop = FALSE])
if (!nc == 0) {
x@ratings[pos, , ] <- x@scale$max - x@ratings[pos, , , drop = FALSE] + x@scale$min # TODO: maybe swapping not correct for layers 2 and 3???
}
x
}
#' @export
#' @rdname reverse
reverse <- function(x, pos = 1L:nrow(x)) {
stop_if_not_is_repgrid(x)
stop_if_scale_not_defined(x)
nc <- nrow(x)
if (any(pos <= 0 | pos > nc)) {
stop("all 'pos' must lie in the interval [1, ", nc, "]", call. = FALSE)
}
# swap names of poles
lp <- leftpoles(x)[pos]
rp <- rightpoles(x)[pos]
leftpoles(x)[pos] <- rp
rightpoles(x)[pos] <- lp
# reverse ratings
sc <- getScale(x)
R <- ratings(x)
R[pos, ] <- sc["max"] - R[pos, ] + sc["min"]
ratings(x) <- R
x
}
#' Move construct or element in grid to the left, right, up or down.
#'
#' @param x `repgrid` object.
#' @param pos Row (column) number of construct (element) to be moved
#' leftwards, rightwards, upwards or downwards.
#' The default is `0`. For indexes outside the range of
#' the grid no moving is done.
#' @return `repgrid` object.
#' @export
#' @aliases left right up down
#' @examples \dontrun{
#' x <- randomGrid()
#' left(x, 2) # 2nd element to the left
#' right(x, 1) # 1st element to the right
#' up(x, 2) # 2nd construct upwards
#' down(x, 1) # 1st construct downwards
#' }
#' @rdname move
#' @keywords internal
left <- function(x, pos = 0) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("Object x must be of class 'repgrid'.")
}
if (!(pos <= 1 | pos > getNoOfElements(x) | pos > ncol(x@ratings))) { # no moving if element is in first or last column
x <- swapElements(x, pos, pos - 1)
}
x
}
# @param x repgrid object
# @param pos column number of element to be moved to the right
#' Move element to the right
#'
#' Move element in grid to the right.
#'
#' @return `repgrid` object
#' @export
#' @rdname move
#' @keywords internal
right <- function(x, pos = 0) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("Object x must be of class 'repgrid'.")
}
if (!(pos < 0 | pos >= getNoOfElements(x) | pos >= ncol(x@ratings))) { # no moving if element is in first or last column
x <- swapElements(x, pos, pos + 1)
}
# x <- e.moveElementRightwards(x, pos=pos)
# x <- r.moveRatingsColumnRightwards(x, pos=pos)
x
}
# @param x repgrid object
# @param pos row number of construct to be moved upwards
#' Move construct in grid upwards.
#'
#' @return `repgrid` object
#' @export
#' @rdname move
#' @keywords internal
up <- function(x, pos = 0) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("Object x must be of class 'repgrid'")
}
if (!(pos <= 1 | pos > getNoOfConstructs(x) | pos > nrow(x@ratings))) {
x <- swapConstructs(x, pos, pos - 1)
}
# x <- c.moveConstructUpwards(x, pos=pos)
# x <- r.moveRatingsRowUpwards(x, pos=pos)
x
}
# @param x repgrid object
# @param pos row number of construct to be moved downwards
#' Move construct in grid downwards.
#'
#' @return `repgrid` object
#' @export
#' @rdname move
#' @keywords internal
down <- function(x, pos = 0) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("Object x must be of class 'repgrid'")
}
if (!(pos < 1 | pos >= getNoOfConstructs(x) | pos >= nrow(x@ratings))) {
x <- swapConstructs(x, pos, pos + 1)
}
# x <- c.moveConstructDownwards(x, pos=pos)
# x <- r.moveRatingsRowDownwards(x, pos=pos)
x
}
#' Shift construct or element to first position.
#'
#' Shifts the whole grid vertically or horizontally so that the order remains
#' the same but the prompted element or construct appears in first position.
#'
#' @param x `repgrid` object.
#' @param c Index of construct to be shifted to first position.
#' @param e Index of element to be shifted to first position.
#' @return `repgrid` object.
#' @export
#' @keywords internal
#' @examples \dontrun{
#'
#' # shift element 13: 'Ideal self' to first position
#' shift(feixas2004, 13)
#'
#' x <- randomGrid(5, 10)
#' shift(x, 3, 5)
#' }
#'
shift <- function(x, c = 1, e = 1) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("Object x must be of class 'repgrid'")
}
if (e < 1 | c < 1) {
stop(
"Element or construct to be shifted to first position must have",
" a positive index"
)
}
ne <- length(x@elements)
nc <- length(x@constructs)
x[ring(1:nc + c - 1, nc), ring(1:ne + e - 1, ne)]
}
############################# CHANGE CONTENT #################################
# rating <- function(x, scores=NA, rows=NA, cols=NA){
# #x <- r.setRatings(x, scores=scores, rows=rows, cols=cols, layer=1)
# }
r.setRatings <- function(x, scores = NA, rows = NA, cols = NA, layer = 1, ...) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("Object x must be of class 'repgrid'.")
}
if (is.list(scores) & !is.data.frame(scores)) {
stop("scores must not be a list.")
}
if (!(is.matrix(scores) | is.data.frame(scores) | is.vector(scores))) { # check if scores is matrix, dataframe or vector
stop("scores must be matrix, dataframe or vector.")
}
if (is.data.frame(scores)) {
scores <- as.matrix(scores)
}
if (is.na(rows[1]) & length(rows) == 1) {
rows <- 1:nrow(x@ratings)
}
if (is.na(cols[1]) & length(cols) == 1) {
cols <- 1:ncol(x@ratings)
}
if (max(rows) > nrow(x@ratings)) {
stop("number of constructs does not exists.")
}
if (max(cols) > ncol(x@ratings)) {
stop("number of elements does not exists.")
}
x@ratings[rows, cols, layer] <- scores
x
}
rating <- r.setRatings
#' clear ratings
#'
#' set certain ratings in grid to NA (unknown)
#'
#' @param x repgrid object
#' @param rows rows to be set NA
#' @param cols columns to be set NA
#' @param layer layer of ratings to be set NA. Usually not important for the user (default = 1).
#' @return `repgrid` object
#' @export
#' @keywords internal
#' @examples \dontrun{
#'
#' #### TODO ####
#' }
clearRatings <- function(x, rows = NA, cols = NA, layer = 1) {
x[rows, cols, layer] <- NA
x
}
# clearRatings(x, 1, 1)
#' Add an element to an existing grid.
#'
#' @param x `repgrid` object.
#' @param name Name of the new element (character string).
#' @param scores Numerical ratings for the new element column
#' (length must match number of constructs in the grid).
#' @param abbreviation Abbreviation for element name.
#' @param status Element status (not yet in use).
#' @param position An integer at which column the element will be added.
#' TODO: Does not work properly yet.
#' @param side Not yet in use.
#' @return `repgrid` object
#' @export
#' @keywords internal
#' @seealso [addConstruct()]
#' @examples \dontrun{
#'
#' bell2010
#' addElement(bell2010, "new element", c(1, 2, 5, 4, 3, 6, 5, 2, 7))
#' }
#'
addElement <- function(x, name = NA, scores = NA, abbreviation = NA, status = NA, position = NA, side = "pre") {
if (length(name) > 1 | length(abbreviation) > 1 | length(status) > 1) {
stop("USERINFO: name, abbreviation and status must be of length one")
}
if (is.na(position)) {
position <- ncol(x@ratings) + 1
}
x <- e.addElements(x,
name = name, abbreviation = abbreviation,
status = status, position = position, side = side
) # basic element operation
x <- r.makeNewElementColumn(x, pos = position) # add column to ratings array
# add scores/ratings
if (length(scores) != length(x@constructs) &
!is.na(scores[1]) & length(scores) != 1) {
warning("The number of ratings you entered do not match the number of constructs.")
scores <- scores[1:length(x@constructs)] # missing scores are filled up with NAs
}
if (length(x@constructs) > 0) {
x <- rating(x, scores, cols = position)
}
return(x)
}
# x <- makeEmptyRepgrid()
# x <- addElement(x)
#' Add a new average element
#'
#' A new element is added to the grid. The scores are the arithmetic means
#' across all selected elements.
#'
#' @param x A `repgrid` object.
#' @param name Name of new element.
#' @param i Indexes of elements to be averaged across. Negative indexes can be
#' used to exclude elements from the complete set. Duplicate indexes are
#' allowed but a warning is issued.
#' @param digits Digits to round mean value to. By default no rounding is used
#' (`digits = Inf`). Use `digits = 0` to round to nearest integer, i.e. only
#' using original integer rating scores.
#' @return A `repgrid` object with additional new element.
#' @export
#' @keywords internal
#' @examples
#' addAvgElement(feixas2004, "others", i = 2:12)
#' addAvgElement(feixas2004, "others", i = 2:12, digits = 0) # integers
#'
#' # exluding elements via negative indexes
#' addAvgElement(feixas2004, "others", i = c(-1, -13))
#'
addAvgElement <- function(x, name = "avg", i, digits = Inf) {
if (!is.repgrid(x)) {
stop("'x' must be a repgrid object", call. = FALSE)
}
if (name %in% elements(x)) {
stop("element name '", name, "' already exists,", call. = FALSE)
}
nc <- ncol(x)
if (!is.numeric(i) || !length(i) >= 1) {
stop("'i' must be a numeric vector with at least one entry", call. = FALSE)
}
if (!all(abs(i) >= 1) && all(abs(i) <= nc)) {
stop("'i' must range between 1 and ", nc, call. = FALSE)
}
if (any(i < 0) && any(i > 0)) {
stop("It is not allowed to mix positive and negative indexes", call. = FALSE)
}
if (sum(duplicated(abs(i))) > 0) {
warning("duplicate indexes detected in 'i'", call. = FALSE)
}
# convert negative indexes
if (all(i < 0)) {
i <- setdiff(1L:nc, abs(i))
}
R <- ratings(x)
mean_ratings <- rowMeans(R[, i, drop = FALSE])
mean_ratings <- round(mean_ratings, digits = digits)
x <- addElement(x, name = name, scores = mean_ratings)
x
}
#' Add a new construct to an existing grid object.
#'
#' @param x `repgrid` object.
#' @param l.name Name of the left pole (character string).
#' @param r.name Name of the right pole (character string).
#' @param scores Numerical ratings for the new construct row
#' (length must match number of elements in the grid).
#' @param l.preferred Is the left one the preferred pole? (logical).
#' @param r.preferred Is the right one the preferred pole? (logical).
#' @param l.emerged Is the left one the emergent pole? (logical).
#' @param r.emerged Is the right one the emergent pole? (logical).
#' @param position An integer at which row the construct will be added.
#' TODO. Does not work properly.
#' @param side Not yet in use.
#' @return `repgrid` object.
#' @export
#' @keywords internal
#' @seealso [addElement()]
#'
#' @examples \dontrun{
#'
#' # show grid
#' bell2010
#' addConstruct(bell2010, "left pole", "pole right", c(3, 1, 3, 2, 5, 4, 6, 3, 7, 1))
#' }
#'
addConstruct <- function(x, l.name = NA, r.name = NA, scores = NA,
l.preferred = NA, r.preferred = NA,
l.emerged = NA, r.emerged = NA,
position = NA, side = "pre") {
if (is.na(position)) position <- length(x@constructs) + 1
x <- c_addConstruct(x,
l.name = l.name, l.preferred = l.preferred, l.emerged = l.emerged,
r.name = r.name, r.preferred = r.preferred, r.emerged = r.emerged,
position = position, side = side
)
x <- r_makeNewConstructRow(x, pos = position)
# add scores/ratings
if (length(scores) != length(x@elements) & !is.na(scores[1]) & length(scores) != 1) {
warning("The number of ratings you entered do not match the number of elements.")
scores <- scores[1:length(x@elements)] # missing scores are filled up with NAs
}
if (length(x@elements) > 0) {
x <- rating(x, scores, rows = position)
}
return(x)
}
# x <- makeEmptyRepgrid()
# x <- addConstruct(x)
#### RENAMING ####
#' Set the attributes of an element
#'
#' Set the attributes of an element i.e. name, abbreviation, status etc.
#'
#' @param x `repgrid` object.
#' @param pos Column number of element in the grid whose attributes
#' are changed.
#' @param name New element name (optional).
#' @param abb Abbreviation of element name (optional).
#' @param status Status of element (e.g. ideal etc.) (optional).
#' @return `repgrid` object
#'
#' @note Currently the main purpose is to change element names.
#' Future implementations will allow to set further attributes.
#' @export
#' @keywords internal
#' @seealso [setConstructAttr()]
#' @examples \dontrun{
#'
#' x <- setElementAttr(boeker, 1, "new name") # change name of first element
#' x
#' }
#'
setElementAttr <- function(x, pos, name, abb, status) {
e <- x@elements[[pos]]
if (!missing(name)) {
e$name <- name
}
if (!missing(abb)) {
e$abbreviation <- abb
}
if (!missing(status)) {
e$status <- status
}
x@elements[pos] <- list(e)
x
}
# setElementAttr(x, 1) # no action
# setElementAttr(x, 1, "test") # new name
# setElementAttr(x, 1, abb="test") # new abbreviation
# setElementAttr(x, 1, status="ideal") # new status
# setElementAttr(x, 1, "new name",
# "new abbreviation", "new status") # all new
#' Set the attributes of a construct
#'
#' Set the attributes of a construct i.e. name, abbreviation, status etc.
#'
#' @param x `repgrid` object.
#' @param pos Row number of construct in the grid to be changed
#' @param l.name Name of the left pole (string) (optional).
#' @param r.name Name of the right pole (string) (optional).
#' @param l.preferred Logical. Is the left one the preferred pole? (optional).
#' @param r.preferred Logical. Is the right one the preferred pole? (optional).
#' @param l.emerged Logical. Is the left one the emergent pole? (optional).
#' @param r.emerged Logical. Is the right one the emergent pole? (optional).
#' @return `repgrid` object
#'
#' @export
#' @keywords internal
#' @seealso [setElementAttr()]
#' @examples \dontrun{
#'
#' x <- setConstructAttr(
#' bell2010, 1,
#' "new left pole", "new right pole"
#' )
#' x
#' }
#'
setConstructAttr <- function(x, pos, l.name, r.name, l.preferred, r.preferred,
l.emerged, r.emerged) {
con <- x@constructs[[1]]
if (!missing(l.name)) {
con$leftpole$name <- l.name
}
if (!missing(l.preferred)) {
con$leftpole$preffered <- l.preferred
}
if (!missing(l.emerged)) {
con$leftpole$emerged <- l.emerged
}
if (!missing(r.name)) {
con$rightpole$name <- r.name
}
if (!missing(r.preferred)) {
con$rightpole$preffered <- r.preferred
}
if (!missing(r.emerged)) {
con$rightpole$emerged <- r.emerged
}
x@constructs[pos] <- list(con)
x
}
# setConstructAttr(x, 1, l.n="halle")
# MAYBE OBSOLETE as setConstructAttr does the same.
# modifyConstructs() allows to change the properties of a construct (left and
# right pole as well as preferred and emergent property). By default the new
# values get added to the old ones, i.e. specifying l.name only overwrites
# l.name. If you want to reset all properties use replace=TRUE. Default
# is NA for all properties.
#' modify a construct
#'
#' change the attributes of a construct
#'
#' @param x repgrid object
#' @param pos row number of construct in the grid to be changed
#' @param l.name (optional) name of the left pole (string)
#' @param r.name (optional) name of the right pole (string)
#' @param l.preferred (optional) is the left one the preferred pole? (logical)
#' @param r.preferred (optional) is the right one the preferred pole? (logical)
#' @param l.emerged (optional) is the left one the emergent pole? (logical)
#' @param r.emerged (optional) is the right one the emergent pole? (logical)
#' @param replace should the sttributes be replaced if NA is provided?
#' @return `repgrid` object
#' @export
#' @keywords internal
#' @examples \dontrun{
#'
#' #### TODO ####
#' }
#'
modifyConstruct <- function(x, pos, l.name = NA, l.preferred = NA, l.emerged = NA,
r.name = NA, r.preferred = NA, r.emerged = NA,
replace = FALSE) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("Object x must be of class 'repgrid'")
}
cs <- c_makeNewConstruct(
x = NULL,
l.name = l.name,
l.preferred = l.preferred,
l.emerged = l.emerged,
r.name = r.name,
r.preferred = r.preferred,
r.emerged = r.emerged
)
if (replace) {
x@constructs[pos] <- list(modifyList(x@constructs[[pos]], cs))
} else {
x@constructs[pos] <- list(modifyListNA(x@constructs[[pos]], cs))
}
x
}
#' modifyElement
#'
#' change the attributes of an element i.e. name, abbreviation, status etc.
#'
#' @param x repgrid object
#' @param pos column number of element in the grid whose attributes are changed
#' @param name (optional) new name
#' @param abbreviation (optional) abbreviation of element name
#' @param status (optional) status of element (e.g. ideal etc.)
#' @param replace logical. whether to overwrite current settings if NA provided
#' @return `repgrid` object
#' @export
#' @keywords internal
#' @examples \dontrun{
#'
#' #### TODO ####
#' }
modifyElement <- function(x, pos, name = NA, abbreviation = NA, status = NA,
replace = FALSE) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("Object x must be of class 'repgrid'")
}
e <- e.makeNewElement(
x = NULL, name = name,
abbreviation = abbreviation, status = status
)
if (replace) {
x@elements[pos] <- list(modifyList(x@elements[[pos]], e))
} else {
x@elements[pos] <- list(modifyListNA(x@elements[[pos]], e))
}
x
}
# x <- makeEmptyRepgrid()
# x <- addElements(x, c("Element 1", "Element 2"))
# x <- modifyElement(x, pos=2, name="test")
#' Print scale range information to the console.
#'
#' @param x `repgrid` object.
#' @return `NULL`.
#' @export
#' @keywords internal
#' @examples \dontrun{
#'
#' showScale(raeithel)
#' showScale(bell2010)
#' }
#'
showScale <- function(x) {
cat("\nSCALE INFO:\n")
if (!is.null(x@scale$min) & !is.null(x@scale$max)) {
cat(
"The grid is rated on a scale from", x@scale$min,
"(left pole) to", x@scale$max, "(right pole)\n"
) # ,
# "using steps of", x@scale$step, "\n")
} else {
cat(
"warning: the scale for this grid is not defined.",
"Certain functions rely on the scale definition.",
"To define the scale use setScale().",
"For more info type ?setScale to the console.\n"
)
}
invisible(NULL)
}
# showScale(x)
# the slot coupled can be influenced
# If a grid is changed from couled to uncoupled, the data is double but
# with reflected scales. A scale range has to be defined for that operations
setCoupled <- function(x, coupled = TRUE) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("Object x must be of class 'repgrid'")
}
if (isTRUE(x@coupled) & !coupled) {
x <- doubleEntry(x)
}
x
}
# x <- bell2010
# x <- setCoupled(x)
#' showMeta
#'
#' prints meta information about the grid to the console (id, name of interviewee etc.)
#'
#' @param x repgrid object
#' @return `NULL`
#' @export
#' @keywords internal
#' @examples \dontrun{
#'
#' #### TODO ####
#' }
#'
showMeta <- function(x) {
cat("\nMETA DATA:\n")
if (!is.null(x@meta$type)) {
cat("Grid type: ", x@meta$type, "\n")
} # print Meta data
if (!is.null(x@meta$id)) {
cat("Interview id: ", x@meta$id, "\n")
} # print Meta data
if (!is.null(x@meta$name)) {
cat("Name of interview partner: ", x@meta$name, "\n")
}
cat("Number of constructs: ", length(x@constructs), "\n")
cat("Number of elements: ", length(x@elements), "\n")
}
# showMeta(x)
#' Make a new repgrid object.
#'
#' The function creates a `repgrid`
#' object from scratch. A number of parameters have to be defined in order to
#' make a new grid (see parameters).
#'
#' @param args Arguments needed for the construction of the grid (list).
#' These include `name` followed by a vector containing
#' the element names. `l.name` followed by a vector with
#' the left construct poles. `r.name` followed by a
#' vector with the right construct poles. `scores` followed
#' by a vector containing the rating scores row wise.
#' @return `NULL`
#' @export
#' @keywords internal
#' @examples \dontrun{
#'
#' # make list object containing the arguments
#' args <- list(
#' name = c("element_1", "element_2", "element_3", "element_4"),
#' l.name = c("left_1", "left_2", "left_3"),
#' r.name = c("right_1", "right_2", "right_3"),
#' scores = c(
#' 1, 0, 1, 0,
#' 1, 1, 1, 0,
#' 1, 0, 1, 0
#' )
#' )
#' # make grid object
#' x <- makeRepgrid(args)
#' x
#' }
#'
makeRepgrid <- function(args) {
x <- makeEmptyRepgrid()
l <- c(list(x = x), args) # make a new repgrid object
x <- do.call(e.setElements, l)
l <- c(list(x = x), args) # make a new repgrid object
x <- do.call(c_setConstructs, l)
x <- initRatingArray(x) # initialize rating array
l <- c(list(x = x), args) # make a new repgrid object
x[, ] <- matrix(args$scores, ncol = getNoOfElements(x), byrow = T) # to fill matrix rowwise
# x <- do.call(r.setRatings, l) # old version
l <- c(list(x = x), args) # make a new repgrid object
x <- do.call(rg.setCoupled, l) # if no coupled argument then coupled=TRUE
l <- c(list(x = x), args) # make a new repgrid object
x <- do.call(setScale, l) # set scale if min and max arg is provided
x
}
# args <- list( name=c("element_1", "element_2", "element_3", "element_4"),
# l.name=c("left_1", "left_2", "left_3"),
# r.name=c("right_1", "right_2", "right_3"),
# scores=c( 1,0,1,0,
# 1,1,1,0,
# 1,0,1,0 ),
# min=0, max=1, coupled=T)
# x <- makeRepgrid(args)
# x <- setScale(x, 0,1)
#' Concatenate the constructs of two grids.
#'
#' I.e. the constructs are combined to form one long grid.
#' This function can be used in order to analyze multiple grids
#' as one 'big grid' (eg. Slater, 1977, chap. 11).
#'
#' @param x `repgrid` object
#' @param y `repgrid` object
#' @param match If the elements do not have the same order they
#' are reordered to match the element order of the first grid 'x'
#' (if `test=TRUE`, default). If set to FALSE an error occurs
#' if the element order is not identical in both grids.
#' @param index TODO. Logical (default `TRUE`). Whether to add an index at the end
#' of each construct name so it remains clear from which grid each
#' construct came.
#'
#' @return `repgrid` object
#'
#' @references Slater, P. (1977). *The measurement of intrapersonal space
#' by grid technique*. London: Wiley.
#'
#' @export
#' @keywords internal
#' @examples \dontrun{
#'
#' a <- randomGrid()
#' b <- randomGrid()
#' elements(b) <- rev(elements(a)) # reverse elements
#' bindConstructs(a, b)
#'
#' bindConstructs(a, b, m = F) # no binding
#' }
#'
bind <- function(x, y, match = TRUE, index = TRUE) {
if (!inherits(x, "repgrid") | !inherits(y, "repgrid")) { # check if x is repgrid object
stop("object x and y must be of class 'repgrid'", call. = FALSE)
}
if (getNoOfElements(x) != getNoOfElements(y)) { # check if grid has same number of columns
stop("grids must have the same number of elements", call. = FALSE)
}
if (any(getScale(x) != getScale(y))) {
stop("concatenated grids must have identical scale ranges", call. = FALSE)
}
names.x <- elements(x)
names.y <- elements(y)
if (!all(names.x %in% names.y)) {
stop("grids must have the same set of elements", call. = FALSE)
}
if (match & !identical(names.x, names.y)) {
# y <- y[ ,orderByString(names.x, names.y)]
reorder.index.y <- match(names.x, names.y) # reorder elements of y by elements of x
y <- y[, reorder.index.y]
} else if (!match & !identical(names.x, names.y)) {
stop(
"elements are the same but dop not have the same order.",
"choose reorder=TRUE if you want to allow matching of element positions"
)
}
x <- x[, ] # to counteract that decoupled arrays are dropped when using [, ]
y <- y[, ]
res <- x
res@ratings <- abind(x@ratings[, , , drop = FALSE],
y@ratings[, , , drop = FALSE],
along = 1
)
res@constructs <- c(x@constructs, y@constructs)
res
}
#' Concatenate the constructs of two or more grids.
#'
#' I.e. the constructs are combined to form one long grid.
#' The girds must have the same set of elements and an identical
#' scale range. The order of the elements may differ.
#'
#' This function can be used in order to analyze multiple grids
#' as one 'big grid' (eg. Slater, 1977, chap. 11).
#'
#' @param ... One or more repgrid objects or a list containing
#' `repgrid` object.
#' @param index TODO. Logical (default `TRUE`). Whether to add an index at the end
#' of each construct name so it remains clear from which grid each
#' construct came.
#'
#' @return `repgrid` object with concatenated constructs.
#'
#' @references Slater, P. (1977). *The measurement of intrapersonal space
#' by grid technique*. London: Wiley.
#' @export
#' @keywords internal
#' @examples
#'
#' a <- randomGrid()
#' b <- randomGrid()
#' elements(b) <- rev(elements(a)) # reverse elements
#' bindConstructs(a, b)
#' bindConstructs(a, b, a)
#'
#' # using lists of repgrid objects
#' bindConstructs(a, list(a, b))
#'
bindConstructs <- function(..., index = FALSE) {
dots <- list(...)
dots <- unlist(dots) # in case list of repgrid objects are supplied
is.grid <- sapply(dots, function(x) inherits(x, "repgrid"))
Reduce("bind", dots[is.grid])
}
# @aliases +,repgrid,repgrid-method
# @docType methods
#' Concatenate repgrid objects.
#'
#' Simple concatenation of repgrid objects or list containing
#' repgrid objects using the '+' operator.
#'
#' Methods for `"+"` function.
#' @param e1,e2 A `repgrid` object.
#' @rdname ops-methods
#' @include repgrid.r
#' @export
#' @examples
#'
#' x <- bell2010
#' x + x
#' x + list(x, x)
#' list(x, x) + x
#'
setMethod(
"+", signature(e1 = "repgrid", e2 = "repgrid"),
function(e1, e2) bindConstructs(e1, e2)
)
#' @docType methods
#' @aliases +,list,repgrid-method
#' @rdname ops-methods
#'
setMethod(
"+", signature(e1 = "list", e2 = "repgrid"),
function(e1, e2) {
bindConstructs(e1, e2)
}
)
#' @docType methods
#' @aliases +,repgrid,list-method
#' @rdname ops-methods
#'
setMethod(
"+", signature(e1 = "repgrid", e2 = "list"),
function(e1, e2) {
bindConstructs(e1, e2)
}
)
#' Join the constructs of a grid with the same reversed constructs.
#'
#'
#' @param x `repgrid` object
#' @return `repgrid` object
#'
#' @export
#' @keywords internal
#' @examples \dontrun{
#'
#' data(bell2010)
#' doubleEntry(bell2010)
#' }
#'
doubleEntry <- function(x) {
bindConstructs(x, swapPoles(x))
}
#' Return size of a grid.
#'
#' `dim` returns a numeric vector of length
#' two containing the number of constructs and elements.
#'
#' @param x `repgrid` object.
#' @return Numeric vector of length two with the number of
#' constructs and elements.
#' @export
#' @keywords internal
#' @method dim repgrid
#' @seealso [getNoOfConstructs()]; [getNoOfElements()]
#' @examples \dontrun{
#'
#' dim(bell2010)
#' }
#'
dim.repgrid <- function(x) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("object x and y must be of class 'repgrid'")
}
c(constructs = getNoOfConstructs(x), elements = getNoOfElements(x))
}
# set status coupled equals TRIE or FALSE. Depending on the setting,
# certain functions will work differently
#
rg.setCoupled <- function(x, coupled = TRUE, ...) {
if (!inherits(x, "repgrid")) { # check if x is repgrid object
stop("Object x must be of class 'repgrid'.")
}
x@coupled <- coupled
x
}
#' decouple a grid
#'
#' @param x repgrid object
#' @export
#' @keywords internal
#'
decouple <- function(x) {
if (x@coupled) {
x <- doubleEntry(x)
x@coupled <- FALSE
}
x
}
#' Invert construct and element order
#'
#' @param x A `repgrid` object.
#' @param what A string or numeric to indicate if constructs (`"C"`, `1`) or
#' elements (`"C"`, `1`), or both (`"CE"`, `12`) should be reversed.
#' @param ... Ignored.
#' @export
#' @rdname reorder
#'
#' @examples
#'
#' # invert order of constructs
#' reorder(boeker, "C")
#' reorder(boeker, 1)
#'
#' # invert order of elements
#' reorder(boeker, "E")
#' reorder(boeker, 2)
#'
#' # invert both (default)
#' reorder(boeker)
#' reorder(boeker, "CE")
#' reorder(boeker, 12)
#'
#' # not reordering
#' reorder(boeker, NA)
#'
reorder.repgrid <- function(x, what = "CE", ...) {
if (!is.repgrid(x)) {
stop("Object 'x' must be of class 'repgrid'", call. = FALSE)
}
if (is.null(what) || is.na(what)) {
return(x)
}
what <- toupper(as.character(what))
if (str_detect(what, "C|1")) {
x <- x[rev(seq_len(nrow(x))), ]
}
if (str_detect(what, "E|2")) {
x <- x[, rev(seq_len(ncol(x)))]
}
x
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.