Re-implement textmodel_svmlim() without dependencies
kbenoit
| 1 |
#' Internal function to match a dfm features to a target set
|
|
| 2 |
#'
|
|
| 3 |
#' Takes a dfm and a set of features, and makes them match the features listed
|
|
| 4 |
#' in the set.
|
|
| 5 |
#' @param x input [dfm]
|
|
| 6 |
#' @param features character; a vector of feature names
|
|
| 7 |
#' @param force logical; if `TRUE`, make the new dfm conform to the vector of
|
|
| 8 |
#' features, otherwise return an error message
|
|
| 9 |
#' @keywords internal dfm
|
|
| 10 |
#' @importFrom quanteda is.dfm featnames dfm_match
|
|
| 11 |
#' @examples
|
|
| 12 |
#' quanteda.textmodels:::force_conformance(data_dfm_lbgexample, c("C", "B", "Z"))
|
|
| 13 |
force_conformance <- function(x, features, force = TRUE) { |
|
| 14 | 1 |
if (!is.dfm(x)) |
| 15 |
stop("x must be a dfm") |
|
| 16 | 1 |
if (force) { |
| 17 | 1 |
n <- length(featnames(x)) - length(intersect(featnames(x), features)) |
| 18 | 1 |
if (n) |
| 19 | 1 |
warning(n, " feature", if (n == 1) "" else "s", |
| 20 | 1 |
" in newdata not used in prediction.", |
| 21 | 1 |
call. = FALSE, noBreaks. = TRUE) |
| 22 | 1 |
return(dfm_match(x, features)) |
| 23 |
} else { |
|
| 24 | 1 |
if (!identical(featnames(x), features)) |
| 25 | 1 |
stop("newdata's feature set is not conformant to model terms.") |
| 26 | 1 |
return(x) |
| 27 |
}
|
|
| 28 |
}
|
|
| 29 |
|
|
| 30 |
#' Raise warning of unused dots
|
|
| 31 |
#' @param ... dots to check
|
|
| 32 |
#' @keywords internal
|
|
| 33 |
unused_dots <- function(...) { |
|
| 34 | 1 |
arg <- names(list(...)) |
| 35 | 1 |
if (length(arg) == 1) { |
| 36 | 1 |
warning(arg[1], " argument is not used.", call. = FALSE) |
| 37 | 1 |
} else if (length(arg) > 1) { |
| 38 | 1 |
warning(paste0(arg, collapse = ", "), " arguments are not used.", call. = FALSE) |
| 39 |
}
|
|
| 40 |
}
|
|
| 41 |
|
|
| 42 |
#' Print friendly object class not defined message
|
|
| 43 |
#'
|
|
| 44 |
#' Checks valid methods and issues a friendlier error message in case the method is
|
|
| 45 |
#' undefined for the supplied object type.
|
|
| 46 |
#' @param object_class character describing the object class
|
|
| 47 |
#' @param function_name character which is the function name
|
|
| 48 |
#' @keywords internal
|
|
| 49 |
#' @examples
|
|
| 50 |
#' # as.tokens.default <- function(x, concatenator = "", ...) {
|
|
| 51 |
#' # stop(quanteda:::friendly_class_undefined_message(class(x), "as.tokens"))
|
|
| 52 |
#' # }
|
|
| 53 |
friendly_class_undefined_message <- function(object_class, function_name) { |
|
| 54 | 1 |
valid_object_types <- as.character(utils::methods(function_name)) |
| 55 | 1 |
valid_object_types <- stringi::stri_replace_first_fixed(valid_object_types, |
| 56 | 1 |
paste0(function_name, "."), "") |
| 57 | 1 |
valid_object_types <- valid_object_types[valid_object_types != "default"] |
| 58 | 1 |
paste0(function_name, "() only works on ", |
| 59 | 1 |
paste(valid_object_types, collapse = ", "), |
| 60 | 1 |
" objects.") |
| 61 |
}
|
|
| 62 |
|
|
| 63 |
#' Return an error message
|
|
| 64 |
#' @param key type of error message
|
|
| 65 |
#' @keywords internal
|
|
| 66 |
message_error <- function(key = NULL) { |
|
| 67 | 1 |
msg <- c("dfm_empty" = "dfm must have at least one non-zero value", |
| 68 | 1 |
"fcm_empty" = "fcm must have at least one non-zero value", |
| 69 | 1 |
"fcm_context" = "fcm must be created with a document context", |
| 70 | 1 |
"matrix_mismatch" = "matrix must have the same rownames and colnames", |
| 71 | 1 |
"docnames_mismatch" = "docnames must the the same length as x", |
| 72 | 1 |
"docvars_mismatch" = "data.frame must have the same number of rows as documents", |
| 73 | 1 |
"docvars_invalid" = "document variables cannot begin with the underscore", |
| 74 | 1 |
"docvar_nofield" = "you must supply field name(s)", |
| 75 | 1 |
"docvar_nocolname" = "data.frame must have column names") |
| 76 | 1 |
if (is.null(key) || !key %in% names(msg)) { |
| 77 |
return("") |
|
| 78 |
}
|
|
| 79 | 1 |
return(unname(msg[key])) |
| 80 |
}
|
|
| 81 |
|
|
| 82 |
# rdname catm
|
|
| 83 |
# messages() with some of the same syntax as cat(): takes a sep argument and
|
|
| 84 |
# does not append a newline by default
|
|
| 85 |
catm <- function(..., sep = " ", appendLF = FALSE) { |
|
| 86 |
message(paste(..., sep = sep), appendLF = appendLF) |
|
| 87 |
}
|
|
| 88 |
|
|
| 89 |
|
|
| 90 |
## make cols add up to one
|
|
| 91 |
colNorm <- function(x) { |
|
| 92 |
x / outer(rep(1, nrow(x)), colSums(x)) |
|
| 93 |
}
|
|
| 94 |
|
|
| 95 |
## fast way to group by class for sparse matrix
|
|
| 96 |
## outputs a dense matrix
|
|
| 97 |
group_classes <- function(x, y, smooth = 0) { |
|
| 98 | 1 |
levels <- levels(as.factor(y)) |
| 99 | 1 |
x <- lapply(levels, function(lev) Matrix::colSums(x[y == lev, , drop = FALSE]) + smooth) |
| 100 | 1 |
names(x) <- levels |
| 101 | 1 |
do.call("rbind", x) |
| 102 |
}
|
|
| 103 |
|
Read our documentation on viewing source code .