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 0
        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 0
        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 0
    message(paste(..., sep = sep), appendLF = appendLF)
87
}
88

89

90
## make cols add up to one
91
colNorm <- function(x) {
92 0
    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 .

Loading