1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
#' @title Mean Square Error
#' @description Calculates the mean square error
#'
#' @param actual A vector of the labels
#' @param predicted A vector of predicted values
#' @param \dots additional parameters to be passed the the s3 methods
#' @param modelObject the model object. Currently supported \code{lm}
#'
#' @examples
#' data(testDF)
#' glmModel <- glm(y ~ ., data = testDF, family="binomial")
#' Preds <- predict(glmModel, type = 'response')
#'
#' mse(testDF$y, Preds)
#'
#' @export
mse <- function(...){
UseMethod("mse")
}
#' @rdname mse
#' @export
mse.default <- function(actual, predicted, ...){
mse_(actual, predicted)
}
#' @rdname mse
#' @export
mse.lm <- function(modelObject, ...){
predicted <- modelObject$fitted.values
actual <- modelObject$residuals + predicted
mse.default(actual, predicted)
}
#' @rdname mse
#' @export
mse.glm <- function(modelObject, ...){
family <- family(modelObject)[[1]]
if(any(family %in% c('binomial', 'poisson'))){
actual <- modelObject$y
predicted <- modelObject$fitted.values
} else {
stop(paste0("family: ", family, " is not currently supported"))
}
mse.default(actual, predicted)
}
#' @title Root-Mean Square Error
#' @description Calculates the root mean square error
#'
#' @param actual A vector of the labels
#' @param predicted A vector of predicted values
#' @param \dots additional parameters to be passed the the s3 methods
#' @param modelObject the model object. Currently supported \code{lm}
#'
#' @examples
#' data(testDF)
#' glmModel <- glm(y ~ ., data = testDF, family="binomial")
#' Preds <- predict(glmModel, type = 'response')
#'
#' rmse(testDF$y, Preds)
#'
#' @export
rmse <- function(...){
UseMethod("rmse")
}
#' @rdname rmse
#' @export
rmse.default <- function(actual, predicted, ...){
rmse_(actual, predicted)
}
#' @rdname rmse
#' @export
rmse.lm <- function(modelObject, ...){
predicted <- modelObject$fitted.values
actual <- modelObject$residuals + predicted
rmse.default(actual, predicted)
}
#' @rdname rmse
#' @export
rmse.glm <- function(modelObject, ...){
family <- family(modelObject)[[1]]
if(any(family %in% c('binomial', 'poisson'))){
actual <- modelObject$y
predicted <- modelObject$fitted.values
} else {
stop(paste0("family: ", family, " is not currently supported"))
}
rmse.default(actual, predicted)
}
|
