gof distinguish train and valid

Author: kongdd

NAMESPACE

@@ -20,6 +20,7 @@ export(previous_tn)
 import(magrittr)
 import(ranger)
 import(xgboost)
+importFrom(Ipaper,melt_list)
 importFrom(data.table,as.data.table)
 importFrom(data.table,data.table)
 importFrom(dplyr,across)

R/GOF.R

@@ -151,7 +151,7 @@ GOF <- function(yobs, ysim, w, include.cv = FALSE, include.r = TRUE) {
 
     if (include.r) out <- c(R2 = R2, out, R = R, pvalue = pvalue)
     if (include.cv) out <- c(out, CV_obs = CV_obs, CV_sim = CV_sim)
-    return(out)
+    as.data.table(as.list(out))
 }
 
 #' weighted CV

R/kfold-package.R

@@ -3,6 +3,7 @@
 #' @importFrom data.table data.table as.data.table
 #' @importFrom purrr map is_empty
 #' @importFrom dplyr mutate across 
+#' @importFrom Ipaper melt_list
 #' @import magrittr
 #' 
 "_PACKAGE"
@@ -16,9 +17,7 @@ NULL
 .onLoad <- function(libname, pkgname) {
     if (getRversion() >= "2.15.1") {
         utils::globalVariables(
-            c(
-                "."
-            )
+            c(".")
         )
     }
 }

R/kfold_calib.R

@@ -14,28 +14,31 @@ kfold_calib <- function(X, Y, FUN = xgboost, index=NULL, ..., ratio_valid=0.3) {
     y_test <- Y[index, , drop = F]
 
     m <- FUN(x_train, y_train, ...)
-    ypred <- predict(m, x_test)
-    list(gof = GOF(y_test, ypred), ypred = ypred, model = m)
+    ypred_train <- predict(m, x_train)
+    ypred_test <- predict(m, x_test)
+
+    gof = list(
+        train = GOF(y_train, ypred_train), 
+        test = GOF(y_test, ypred_test)
+    ) %>% melt_list("type")
+    list(gof = gof, ypred = ypred_test, model = m)
 }
 
 #' @export
 kfold_tidy <- function(res, ind_lst, Y) {
     kfold_names <- names(ind_lst)
     if (is.null(kfold_names)) kfold_names <- paste0(seq_along(ind_lst))
 
-    ## 3. GOF information get
+    ## GOF information get
     val <- map(res, ~ .x$ypred) %>% unlist() # pred value
     ypred <- Y * NA
     ypred[unlist(ind_lst)] <- val
-    info_all <- GOF(Y, ypred)
+    info_all <- cbind(type = "valid", GOF(Y, ypred))
 
     model <- map(res, "model")
-    gof <- map(res, "gof") %>%
+    gof <- map(res, "gof") %>% set_names(kfold_names) %>% 
         c(., all = list(info_all)) %>%
-        do.call(rbind, .) %>%
-        as.data.table()
-    gof$kfold <- c(kfold_names, "all")
-
+        melt_list("kfold") %>% data.table()
     listk(gof, ypred, index = ind_lst, model) %>% set_class("kfold") # how to return back to original value?
 }
 

R/kford_ml.R

@@ -38,9 +38,8 @@ kfold_rf <- function(X, Y, kfold = 5,
 #' @import xgboost
 #' @rdname kfold_ml
 #' @export
-kfold_xgboost <- function(X, Y, kfold = 5, verbose = FALSE, nrounds = 500, ...) {
-    kfold_ml(X, Y, kfold,
-        FUN = xgboost, nrounds = nrounds, verbose = verbose, ...)
+kfold_xgboost <- function(X, Y, kfold = 5, nrounds = 500, ...) {
+    kfold_ml(X, Y, kfold, FUN = xgboost, nrounds = nrounds, ...)
 }
 
 #' @rdname kfold_ml
@@ -58,7 +57,7 @@ predict.ranger <- function(object, data = NULL, ...) {
 
 #' @import ranger
 ranger <- function(x, y, ntree = 500, ...) {
-    ranger::ranger(x = x, y = y, num.trees = ntree, ...)
+    ranger::ranger(x = x, y = drop(y), num.trees = ntree, ...)
 }
 
 # ' @export