Nothing
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%####
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%% get_max_possible_total_score %%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' Calculate the maximum score of a set of items
#' @param ip An \code{\link{Itempool-class}} object.
#' @param resp (optional) A response vector or a response matrix. The contents
#' are not important. The function only checks whether an element is missing
#' or not. If an element is missing, then that item will not count towards
#' the maximum possible score. If the maximum score of all items are needed,
#' set \code{resp = NULL}.
#'
#' @return A vector of numbers showing the maximum possible scores.
#'
#' @export
#'
#' @author Emre Gonulates
#'
#' @examples
#' ip <- generate_ip(n = 10)
#' get_max_possible_total_score(ip)
#' # A mixture of dichotomous and polytomous items
#' ip <- generate_ip(model = c("3PL", "GRM", "3PL", "GRM", "GRM"),
#' n_categories = c(2, 5, 2, 4, 6))
#' # 1 + 4 + 1 + 3 + 5 = 14
#' get_max_possible_total_score(ip)
get_max_possible_total_score <- function(ip, resp = NULL) {
if (!is(ip, "Itempool"))
stop("ip should be an 'Itempool' object.")
max_scores <- ip$item_max_score
if (!is.null(resp)) {
ip_size <- length(max_scores)
if (is.vector(resp)) {
if (length(resp) != ip_size)
stop(paste0("The number of elements of the 'resp' vector should be ",
ip_size, ".\n"))
return(sum(max_scores[!is.na(resp)]))
} else if (is.matrix(resp)) {
if (ncol(resp) != ip_size)
stop(paste0("The number of columns of the 'resp' matrix should be ",
ip_size, ".\n"))
return(rowSums((1*!is.na(resp)) * matrix(
max_scores, ncol = ncol(resp), nrow = nrow(resp), byrow = TRUE)))
}
}
return(sum(max_scores))
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%####
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%% convert_resp %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' Convert responses to wide format
#'
#' @param resp A \code{matrix} or \code{data.frame} containing the item
#' responses. By default, it is assumed that the first column is examinee
#' ids, second column is item ID's and third column is responses.
#' @param examinee_id_col Column name or the column number of the examinee ID
#' column.
#' @param item_id_col Column name or the column number of the item ID column.
#' @param resp_col Column name or the column number of the response column.
#' @param to \code{wide}: convert response data from long to wide.
#' \code{long}: convert response data from wide to long.
#'
#' @return A response \code{matrix} in wide format where row names are
#' examinee ID's and column names are item ID's.
#'
#' @keywords internal
#'
#' @author Emre Gonulates
#'
#' @noRd
#'
convert_resp <- function(resp, examinee_id_col = NULL, item_id_col = NULL,
resp_col = NULL, to = "wide") {
examinee_id_col <- ifelse(is.null(examinee_id_col), 1, examinee_id_col)
item_id_col <- ifelse(is.null(item_id_col), 2, item_id_col)
resp_col <- ifelse(is.null(resp_col), 3, resp_col)
# Order the columns of resp vector and remove unnecessary columns
resp <- resp[, c(examinee_id_col, item_id_col, resp_col)]
colnames(resp) <- c("examinee_id", "item_id", "score")
# Get unique examinee and item ids
examinee_id <- as.character(unique(resp[[examinee_id_col]]))
item_id <- as.character(unique(resp[[item_id_col]]))
# Create a full item response vector in case there are missing values
temp <- cbind(expand.grid(item_id = item_id, examinee_id = examinee_id,
stringsAsFactors = FALSE)[, 2:1])
temp <- merge(temp, resp, by = c("examinee_id", "item_id"), all.x = TRUE)
return(matrix(temp[["score"]], ncol = length(item_id), byrow = TRUE,
dimnames = list(examinee_id, item_id)))
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%####
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%% format_text %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' Colourise text for display in the terminal.
#'
#' If R is not currently running in a system that supports terminal colours
#' the text will be returned unchanged.
#'
#' Allowed colours are: black, blue, brown, cyan, dark gray, green, light
#' blue, light cyan, light gray, light green, light purple, light red,
#' purple, red, white, yellow
#'
#' # This function is literally taken from Hadley Wickham's testthat package:
#' https://github.com/r-lib/testthat/blob/
#' 717b02164def5c1f027d3a20b889dae35428b6d7/R/colour-text.r
#'
#' More formatting options can be found here:
#' https://stackoverflow.com/a/33206814/2275286
#'
#' @param text character vector
#' @param fg foreground colour, defaults to white
#' @param bold whether the text should appear in bold
#' @param italic whether the text should appear in italic
#'
#' @author Emre Gonulates
#'
#' @keywords internal
#'
#' @noRd
#'
format_text <- function(text, fg = "black",
# bg = NULL,
bold = FALSE,
italic = FALSE) {
# Examples:
# print(format_text("Yellow color", "yellow"))
# cat(format_text("Blue color", "blue"), "\n")
# cat(format_text("Gray text", "light gray"), "\n")
# cat(format_text("Bold and green", "green", bold = TRUE), "\n")
# cat(format_text("Italic and purple", "purple", italic = TRUE), "\n")
.fg_colours <- c(
"black" = "0;30",
"blue" = "0;34",
"green" = "0;32",
"cyan" = "0;36",
"red" = "0;31",
"purple" = "0;35",
"brown" = "0;33",
"light gray" = "0;37",
"dark gray" = "1;30",
"light blue" = "1;34",
"light green" = "1;32",
"light cyan" = "1;36",
"light red" = "1;31",
"light purple" = "1;35",
"yellow" = "1;33",
"white" = "1;37"
)
.bg_colours <- c(
"black" = "40",
"red" = "41",
"green" = "42",
"brown" = "43",
"blue" = "44",
"purple" = "45",
"cyan" = "46",
"light gray" = "47"
)
rcmd_running <- function() {
nchar(Sys.getenv('R_TESTS')) != 0
}
term <- Sys.getenv()["TERM"]
colour_terms <- c("xterm-color","xterm-256color", "screen", "screen-256color")
if(rcmd_running() || !any(term %in% colour_terms, na.rm = TRUE)) {
return(text)
}
col_escape <- function(col) {
paste0("\033[", col, "m")
}
col <- .fg_colours[tolower(fg)]
# if (!is.null(bg)) {
# col <- paste0(col, .bg_colours[tolower(bg)], sep = ";")
# }
# Add bold face
col <- ifelse(bold, paste0(col, ";1"), col)
col <- ifelse(italic, paste0(col, ";3"), col)
init <- col_escape(col)
reset <- col_escape("0")
paste0(init, text, reset)
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%####
#%%%%%%%%%%%%%%%%%%%%%%%%%%%% is_integer ###%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%####
#' Check whether a value is integer
#'
#' @keywords internal
#'
#' @author Emre Gonulates
#'
#' @noRd
#'
is_integer <- function(x, tol = 10 * .Machine$double.eps) {
if (is.atomic(x) && !is.matrix(x) && length(x) > 0) {
return(sapply(x, function(k) is.numeric(k) &&
(abs(k - round(k)) <= tol & !is.infinite(k))))
} else if (is.null(x)) {
return(FALSE)
} else if (length(x) == 0) {
return(FALSE)
} else if (inherits(x, "data.frame")) {
return(sapply(x, is_integer))
} else if (is.matrix(x)) {
return(apply(x, 2, is_integer))
}
return(rep(FALSE, length(x)))
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%####
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%% is_single_value %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' Check whether an object is a single length vector
#'
#' \code{NULL} is not acceptable and returns \code{FALSE}
#'
#' @param x An object to be tested
#' @param class class of the object. It can be either \code{NULL},
#' \code{"numeric"}, \code{"integer"}, \code{"character"}, \code{"logical"},
#' \code{"complex"} or \code{Date}. When it is \code{NULL}, it can be either
#' one of the five classes above.
#' @param accept_na If \code{TRUE}, the object is allowed to be a \code{NA}.
#'
#' @return Either \code{TRUE} or \code{FALSE}
#'
#' @keywords internal
#'
#' @author Emre Gonulates
#'
#' @noRd
#'
#' @examples
#' is_single_value(12) # TRUE
#' is_single_value(12, class = "numeric") # TRUE
#' is_single_value(12, class = "character") # FALSE
#' is_single_value("12", class = "character") # TRUE
#' is_single_value(12, class = "logical") # FALSE
#'
#' is_single_value(c(12, 18), class = "numeric") # FALSE
#' is_single_value(12L, class = "numeric") # FALSE
#' is_single_value(12L, class = "integer") # TRUE
#'
#' is_single_value(12, class = c("numeric", "integer")) # TRUE
#' is_single_value(12L, class = c("numeric", "integer")) # TRUE
#' is_single_value(1:5, class = c("numeric", "integer")) # FALSE
#'
#' is_single_value(as.Date("2021-01-01")) # TRUE
#'
is_single_value <- function(x, class = NULL, accept_na = FALSE) {
# if (is.null(accept_na) || !is.atomic(accept_na) || is.matrix(accept_na) ||
# length(accept_na) != 1 || !is.logical(accept_na))
# stop("Invalid 'accept_na'.")
if (is.null(x)) return(FALSE)
if (!accept_na && all(is.na(x))) return(FALSE)
# First check if the value is a single value
if (!is.atomic(x) || is.matrix(x) || length(x) > 1) return(FALSE)
# Check class
acceptable_classes <- c("numeric", "integer", "character", "logical",
"complex", "Date")
if (!is.null(class) && !all(class %in% acceptable_classes))
stop("'class' should be either 'numeric', 'integer', 'character', ",
"'logical', 'complex' or NULL.", call. = FALSE)
if (is.null(class)) class <- acceptable_classes
if (length(class) == 1 && class == "integer") return(is_integer(x))
return(class(x) %in% class)
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%####
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%% is_atomic_vector %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' Check whether an object is an atomic vector
#'
#' \code{NULL} is not acceptable and returns \code{FALSE}
#'
#' @param x An object to be tested
#' @param class class of the object. It can be either \code{NULL},
#' \code{"numeric"}, \code{"integer"}, \code{"character"}, \code{"logical"},
#' \code{"complex"}, \code{"Date"}, or \code{"factor"}.
#' When it is \code{NULL}, it can be either one of the seven classes above.
#' @param accept_na If \code{TRUE}, the object is allowed to be a \code{NA}.
#'
#' @return Either \code{TRUE} or \code{FALSE}
#'
#' @keywords internal
#'
#' @author Emre Gonulates
#'
#' @noRd
#'
#' @examples
#' is_atomic_vector(1:6) # TRUE
#' is_atomic_vector(1:6, class = "integer") # TRUE
#' is_atomic_vector(1:6, class = "numeric") # FALSE
#' is_atomic_vector(1:6, class = c("integer", "numeric")) # TRUE
#'
#' is_atomic_vector(factor(c("a", "d", "a", "b", "c"))) # TRUE
#'
#' is_atomic_vector(matrix(c("a", "d", "a", "b", "c"))) # FALSE
#' is_atomic_vector(data.frame(m = c("a", "d", "a", "b", "c"))) # FALSE
is_atomic_vector <- function(
x,
class = c("numeric", "integer", "character", "logical", "complex", "Date",
# The following is not originally in vector
"factor"),
accept_na = TRUE) {
# if (is.null(accept_na) || !is.atomic(accept_na) || is.matrix(accept_na) ||
# length(accept_na) != 1 || !is.logical(accept_na))
# stop("Invalid 'accept_na'.")
if (is.null(x) || !is.atomic(x) || is.matrix(x)) return(FALSE)
if (!accept_na && any(is.na(x))) return(FALSE)
# Check class
acceptable_classes <- c("numeric", "integer", "character", "logical",
"complex", "Date", "factor")
if (!is.null(class) && !all(class %in% acceptable_classes))
stop("'class' should be either 'numeric', 'integer', 'character', ",
"'logical', 'complex' or NULL.", call. = FALSE)
if (is.null(class)) class <- acceptable_classes
if (length(class) == 1 && class == "integer") return(all(is_integer(x)))
return(inherits(x, class))
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%####
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%% rmsd %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' Calculate Root Mean Square Deviation (RMSD)
#' (or Root Mean Square Error (RMSE))
#'
#' @description The formula for RMSD is:
#'
#' \deqn{RMSD = \sqrt{\frac{\sum_{i = 1}^n(\hat \theta - \theta)^2}{n}}}
#'
#' @param est A numeric vector of estimated values
#' @param true A numeric vector of true values
#'
#' @return A number representing RMSD.
#'
#' @author Emre Gonulates
#'
#' @keywords internal
#'
#' @examples
#' true <- rnorm(10)
#' est <- true + runif(10)
#'
rmsd <- function(est, true) {
if (!is_atomic_vector(true, class = c("numeric", "integer")) ||
!is_atomic_vector(est, class = c("numeric", "integer")))
stop("Both 'est' and 'true' should be numeric.")
if (length(est) != length(true))
stop("The lengths of 'est' and 'true' should be equal")
sqrt(mean((est - true)^2, na.rm = TRUE))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.