1svm <- 2function (x, ...) 3 UseMethod ("svm") 4 5svm.formula <- 6function (formula, data = NULL, ..., subset, na.action = na.omit, scale = TRUE) 7{ 8 call <- match.call() 9 if (!inherits(formula, "formula")) 10 stop("method is only for formula objects") 11 m <- match.call(expand.dots = FALSE) 12 if (inherits(eval.parent(m$data), "matrix")) 13 m$data <- as.data.frame(eval.parent(m$data)) 14 m$... <- NULL 15 m$scale <- NULL 16 m[[1L]] <- quote(stats::model.frame) 17 m$na.action <- na.action 18 m <- eval(m, parent.frame()) 19 Terms <- attr(m, "terms") 20 attr(Terms, "intercept") <- 0 21 x <- model.matrix(Terms, m) 22 y <- model.extract(m, "response") 23 attr(x, "na.action") <- attr(y, "na.action") <- attr(m, "na.action") 24 if (length(scale) == 1) 25 scale <- rep(scale, ncol(x)) 26 if (any(scale)) { 27 remove <- unique(c(which(labels(Terms) %in% 28 names(attr(x, "contrasts"))), 29 which(!scale) 30 ) 31 ) 32 scale <- !attr(x, "assign") %in% remove 33 } 34 ret <- svm.default (x, y, scale = scale, ..., na.action = na.action) 35 ret$call <- call 36 ret$call[[1]] <- as.name("svm") 37 ret$terms <- Terms 38 if (!is.null(attr(m, "na.action"))) 39 ret$na.action <- attr(m, "na.action") 40 class(ret) <- c("svm.formula", class(ret)) 41 return (ret) 42} 43 44svm.default <- 45function (x, 46 y = NULL, 47 scale = TRUE, 48 type = NULL, 49 kernel = "radial", 50 degree = 3, 51 gamma = if (is.vector(x)) 1 else 1 / ncol(x), 52 coef0 = 0, 53 cost = 1, 54 nu = 0.5, 55 class.weights = NULL, 56 cachesize = 40, 57 tolerance = 0.001, 58 epsilon = 0.1, 59 shrinking = TRUE, 60 cross = 0, 61 probability = FALSE, 62 fitted = TRUE, 63 ..., 64 subset, 65 na.action = na.omit) 66{ 67 yorig <- y 68 if(inherits(x, "Matrix")) { 69 loadNamespace("SparseM") 70 loadNamespace("Matrix") 71 x <- as(x, "matrix.csr") 72 } 73 if(inherits(x, "simple_triplet_matrix")) { 74 loadNamespace("SparseM") 75 ind <- order(x$i, x$j) 76 x <- new("matrix.csr", 77 ra = x$v[ind], 78 ja = x$j[ind], 79 ia = as.integer(cumsum(c(1, tabulate(x$i[ind])))), 80 dimension = c(x$nrow, x$ncol)) 81 } 82 if (sparse <- inherits(x, "matrix.csr")) 83 loadNamespace("SparseM") 84 85 ## NULL parameters? 86 if(is.null(degree)) stop(sQuote("degree"), " must not be NULL!") 87 if(is.null(gamma)) stop(sQuote("gamma"), " must not be NULL!") 88 if(is.null(coef0)) stop(sQuote("coef0"), " must not be NULL!") 89 if(is.null(cost)) stop(sQuote("cost"), " must not be NULL!") 90 if(is.null(nu)) stop(sQuote("nu"), " must not be NULL!") 91 if(is.null(epsilon)) stop(sQuote("epsilon"), " must not be NULL!") 92 if(is.null(tolerance)) stop(sQuote("tolerance"), " must not be NULL!") 93 94 xhold <- if (fitted) x else NULL 95 x.scale <- y.scale <- NULL 96 formula <- inherits(x, "svm.formula") 97 98 ## determine model type 99 if (is.null(type)) type <- 100 if (is.null(y)) "one-classification" 101 else if (is.factor(y)) "C-classification" 102 else "eps-regression" 103 104 type <- pmatch(type, c("C-classification", 105 "nu-classification", 106 "one-classification", 107 "eps-regression", 108 "nu-regression"), 99) - 1 109 110 if (type > 10) stop("wrong type specification!") 111 112 kernel <- pmatch(kernel, c("linear", 113 "polynomial", 114 "radial", 115 "sigmoid"), 99) - 1 116 117 if (kernel > 10) stop("wrong kernel specification!") 118 119 nac <- attr(x, "na.action") 120 121 ## scaling, subsetting, and NA handling 122 if (sparse) { 123 scale <- rep(FALSE, ncol(x)) 124 if(!is.null(y)) na.fail(y) 125 x <- SparseM::t(SparseM::t(x)) ## make shure that col-indices are sorted 126 } else { 127 x <- as.matrix(x) 128 129 ## subsetting and na-handling for matrices 130 if (!formula) { 131 if (!missing(subset)) { 132 x <- x[subset,] 133 y <- y[subset] 134 if (!is.null(xhold)) 135 xhold <- as.matrix(xhold)[subset,] 136 } 137 if (is.null(y)) 138 x <- na.action(x) 139 else { 140 df <- na.action(data.frame(y, x)) 141 y <- df[,1] 142 x <- as.matrix(df[,-1], rownames.force = TRUE) 143 nac <- 144 attr(x, "na.action") <- 145 attr(y, "na.action") <- 146 attr(df, "na.action") 147 } 148 } 149 150 ## scaling 151 if (length(scale) == 1) 152 scale <- rep(scale, ncol(x)) 153 if (any(scale)) { 154 co <- !apply(x[,scale, drop = FALSE], 2, var) 155 if (any(co)) { 156 warning(paste("Variable(s)", 157 paste(sQuote(colnames(x[,scale, 158 drop = FALSE])[co]), 159 sep="", collapse=" and "), 160 "constant. Cannot scale data.") 161 ) 162 scale <- rep(FALSE, ncol(x)) 163 } else { 164 xtmp <- scale_data_frame(x[,scale]) 165 x[,scale] <- xtmp 166 x.scale <- attributes(xtmp)[c("scaled:center","scaled:scale")] 167 if (is.numeric(y) && (type > 2)) { 168 yorig <- y 169 y <- scale(y) 170 y.scale <- attributes(y)[c("scaled:center","scaled:scale")] 171 y <- as.vector(y) 172 } 173 } 174 } 175 } 176 177 ## further parameter checks 178 nr <- nrow(x) 179 if (cross > nr) 180 stop(sQuote("cross"), " cannot exceed the number of observations!") 181 182 ytmp <- y 183 attributes(ytmp) <- NULL 184 if (!is.vector(ytmp) && !is.factor(y) && type != 2) 185 stop("y must be a vector or a factor.") 186 if (type != 2 && length(y) != nr) 187 stop("x and y don't match.") 188 189 if (cachesize < 0.1) 190 cachesize <- 0.1 191 192 if (type > 2 && !is.numeric(y)) 193 stop("Need numeric dependent variable for regression.") 194 195 lev <- NULL 196 weightlabels <- NULL 197 198 ## in case of classification: transform factors into integers 199 if (type == 2) # one class classification --> set dummy 200 y <- rep(1, nr) 201 else 202 if (is.factor(y)) { 203 lev <- levels(y) 204 y <- as.integer(y) 205 } else { 206 if (type < 3) { 207 if(any(as.integer(y) != y)) 208 stop("dependent variable has to be of factor or integer type for classification mode.") 209 y <- as.factor(y) 210 lev <- levels(y) 211 y <- as.integer(y) 212 } else lev <- unique(y) 213 } 214 215 if (type < 3 && !is.null(class.weights)) { 216 if (is.character(class.weights) && class.weights == "inverse") { 217 class.weights <- 1 / table(y) 218 names(class.weights) = lev 219 } 220 if (is.null(names(class.weights))) 221 stop("Weights have to be specified along with their according level names !") 222 weightlabels <- match (names(class.weights), lev) 223 if (any(is.na(weightlabels))) 224 stop("At least one level name is missing or misspelled.") 225 } 226 227 nclass <- 2 228 if (type < 2) nclass <- length(lev) 229 230 if (type > 1 && length(class.weights) > 0) { 231 class.weights <- NULL 232 warning(sQuote("class.weights"), " are set to NULL for regression mode. For classification, use a _factor_ for ", sQuote("y"), 233", or specify the correct ", sQuote("type"), " argument.") 234 } 235 236 err <- empty_string <- paste(rep(" ", 255), collapse = "") 237 238 if (is.null(type)) stop("type argument must not be NULL!") 239 if (is.null(kernel)) stop("kernel argument must not be NULL!") 240 if (is.null(degree)) stop("degree argument must not be NULL!") 241 if (is.null(gamma)) stop("gamma argument must not be NULL!") 242 if (is.null(coef0)) stop("coef0 seed argument must not be NULL!") 243 if (is.null(cost)) stop("cost argument must not be NULL!") 244 if (is.null(nu)) stop("nu argument must not be NULL!") 245 if (is.null(cachesize)) stop("cachesize argument must not be NULL!") 246 if (is.null(tolerance)) stop("tolerance argument must not be NULL!") 247 if (is.null(epsilon)) stop("epsilon argument must not be NULL!") 248 if (is.null(shrinking)) stop("shrinking argument must not be NULL!") 249 if (is.null(cross)) stop("cross argument must not be NULL!") 250 if (is.null(sparse)) stop("sparse argument must not be NULL!") 251 if (is.null(probability)) stop("probability argument must not be NULL!") 252 253 cret <- .C (R_svmtrain, 254 ## data 255 as.double (if (sparse) x@ra else t(x)), 256 as.integer (nr), as.integer(ncol(x)), 257 as.double (y), 258 ## sparse index info 259 as.integer (if (sparse) x@ia else 0), 260 as.integer (if (sparse) x@ja else 0), 261 262 ## parameters 263 as.integer (type), 264 as.integer (kernel), 265 as.integer (degree), 266 as.double (gamma), 267 as.double (coef0), 268 as.double (cost), 269 as.double (nu), 270 as.integer (weightlabels), 271 as.double (class.weights), 272 as.integer (length (class.weights)), 273 as.double (cachesize), 274 as.double (tolerance), 275 as.double (epsilon), 276 as.integer (shrinking), 277 as.integer (cross), 278 as.integer (sparse), 279 as.integer (probability), 280 281 ## results 282 nclasses = integer (1), 283 nr = integer (1), # nr of support vectors 284 index = integer (nr), 285 labels = integer (nclass), 286 nSV = integer (nclass), 287 rho = double (nclass * (nclass - 1) / 2), 288 coefs = double (nr * (nclass - 1)), 289 sigma = double (1), 290 probA = double (nclass * (nclass - 1) / 2), 291 probB = double (nclass * (nclass - 1) / 2), 292 293 cresults = double (cross), 294 ctotal1 = double (1), 295 ctotal2 = double (1), 296 error = err 297 298 ) 299 300 if (cret$error != empty_string) 301 stop(paste(cret$error, "!", sep="")) 302 303 cret$index <- cret$index[1:cret$nr] 304 305 ret <- list ( 306 call = match.call(), 307 type = type, 308 kernel = kernel, 309 cost = cost, 310 degree = degree, 311 gamma = gamma, 312 coef0 = coef0, 313 nu = nu, 314 epsilon = epsilon, 315 sparse = sparse, 316 scaled = scale, 317 x.scale = x.scale, 318 y.scale = y.scale, 319 320 nclasses = cret$nclasses, #number of classes 321 levels = lev, 322 tot.nSV = cret$nr, #total number of sv 323 nSV = cret$nSV[1:cret$nclasses], #number of SV in diff. classes 324 labels = cret$labels[1:cret$nclasses], #labels of the SVs. 325 SV = if (sparse) SparseM::t(SparseM::t(x[cret$index])) 326 else t(t(x[cret$index,,drop = FALSE])), #copy of SV 327 index = cret$index, #indexes of sv in x 328 ##constants in decision functions 329 rho = cret$rho[1:(cret$nclasses * (cret$nclasses - 1) / 2)], 330 ##probabilites 331 compprob = probability, 332 probA = if (!probability) NULL else 333 cret$probA[1:(cret$nclasses * (cret$nclasses - 1) / 2)], 334 probB = if (!probability) NULL else 335 cret$probB[1:(cret$nclasses * (cret$nclasses - 1) / 2)], 336 sigma = if (probability) cret$sigma else NULL, 337 ##coefficiants of sv 338 coefs = if (cret$nr == 0) NULL else 339 t(matrix(cret$coefs[1:((cret$nclasses - 1) * cret$nr)], 340 nrow = cret$nclasses - 1, 341 byrow = TRUE)), 342 na.action = nac 343 ) 344 345 ## cross-validation-results 346 if (cross > 0) 347 if (type > 2) { 348 scale.factor <- if (any(scale)) crossprod(y.scale$"scaled:scale") else 1; 349 ret$MSE <- cret$cresults * scale.factor; 350 ret$tot.MSE <- cret$ctotal1 * scale.factor; 351 ret$scorrcoeff <- cret$ctotal2; 352 } else { 353 ret$accuracies <- cret$cresults; 354 ret$tot.accuracy <- cret$ctotal1; 355 } 356 357 class (ret) <- "svm" 358 359 if (fitted) { 360 ret$fitted <- na.action(predict(ret, xhold, 361 decision.values = TRUE)) 362 ret$decision.values <- attr(ret$fitted, "decision.values") 363 attr(ret$fitted, "decision.values") <- NULL 364 if (type > 1) ret$residuals <- yorig - ret$fitted 365 } 366 367 ret 368} 369 370predict.svm <- 371function (object, newdata, 372 decision.values = FALSE, 373 probability = FALSE, 374 ..., 375 na.action = na.omit) 376{ 377 if (missing(newdata)) 378 return(fitted(object)) 379 380 if (object$tot.nSV < 1) 381 stop("Model is empty!") 382 383 384 if(inherits(newdata, "Matrix")) { 385 loadNamespace("SparseM") 386 loadNamespace("Matrix") 387 newdata <- as(newdata, "matrix.csr") 388 } 389 if(inherits(newdata, "simple_triplet_matrix")) { 390 loadNamespace("SparseM") 391 ind <- order(newdata$i, newdata$j) 392 newdata <- new("matrix.csr", 393 ra = newdata$v[ind], 394 ja = newdata$j[ind], 395 ia = as.integer(cumsum(c(1, tabulate(newdata$i[ind])))), 396 dimension = c(newdata$nrow, newdata$ncol)) 397 } 398 399 sparse <- inherits(newdata, "matrix.csr") 400 if (object$sparse || sparse) 401 loadNamespace("SparseM") 402 403 act <- NULL 404 if ((is.vector(newdata) && is.atomic(newdata))) 405 newdata <- t(t(newdata)) 406 if (sparse) 407 newdata <- SparseM::t(SparseM::t(newdata)) 408 preprocessed <- !is.null(attr(newdata, "na.action")) 409 rowns <- if (!is.null(rownames(newdata))) 410 rownames(newdata) 411 else 412 1:nrow(newdata) 413 if (!object$sparse) { 414 if (inherits(object, "svm.formula")) { 415 if(is.null(colnames(newdata))) 416 colnames(newdata) <- colnames(object$SV) 417 newdata <- na.action(newdata) 418 act <- attr(newdata, "na.action") 419 newdata <- model.matrix(delete.response(terms(object)), 420 as.data.frame(newdata)) 421 } else { 422 newdata <- na.action(as.matrix(newdata)) 423 act <- attr(newdata, "na.action") 424 } 425 } 426 427 if (!is.null(act) && !preprocessed) 428 rowns <- rowns[-act] 429 430 if (any(object$scaled)) 431 newdata[,object$scaled] <- 432 scale_data_frame(newdata[,object$scaled, drop = FALSE], 433 center = object$x.scale$"scaled:center", 434 scale = object$x.scale$"scaled:scale" 435 ) 436 437 if (ncol(object$SV) != ncol(newdata)) 438 stop ("test data does not match model !") 439 440 ret <- .C (R_svmpredict, 441 as.integer (decision.values), 442 as.integer (probability), 443 444 ## model 445 as.double (if (object$sparse) object$SV@ra else t(object$SV)), 446 as.integer (nrow(object$SV)), as.integer(ncol(object$SV)), 447 as.integer (if (object$sparse) object$SV@ia else 0), 448 as.integer (if (object$sparse) object$SV@ja else 0), 449 as.double (as.vector(object$coefs)), 450 as.double (object$rho), 451 as.integer (object$compprob), 452 as.double (if (object$compprob) object$probA else 0), 453 as.double (if (object$compprob) object$probB else 0), 454 as.integer (object$nclasses), 455 as.integer (object$tot.nSV), 456 as.integer (object$labels), 457 as.integer (object$nSV), 458 as.integer (object$sparse), 459 460 ## parameter 461 as.integer (object$type), 462 as.integer (object$kernel), 463 as.integer (object$degree), 464 as.double (object$gamma), 465 as.double (object$coef0), 466 467 ## test matrix 468 as.double (if (sparse) newdata@ra else t(newdata)), 469 as.integer (nrow(newdata)), 470 as.integer (if (sparse) newdata@ia else 0), 471 as.integer (if (sparse) newdata@ja else 0), 472 as.integer (sparse), 473 474 ## decision-values 475 ret = double(nrow(newdata)), 476 dec = double(nrow(newdata) * object$nclasses * (object$nclasses - 1) / 2), 477 prob = double(nrow(newdata) * object$nclasses) 478 479 480 ) 481 482 ret2 <- if (is.character(object$levels)) # classification: return factors 483 factor (object$levels[ret$ret], levels = object$levels) 484 else if (object$type == 2) # one-class-classification: return TRUE/FALSE 485 ret$ret == 1 486 else if (any(object$scaled) && !is.null(object$y.scale)) # return raw values, possibly scaled back 487 ret$ret * object$y.scale$"scaled:scale" + object$y.scale$"scaled:center" 488 else 489 ret$ret 490 491 names(ret2) <- rowns 492 ret2 <- napredict(act, ret2) 493 494 if (decision.values) { 495 colns = c() 496 for (i in 1:(object$nclasses - 1)) 497 for (j in (i + 1):object$nclasses) 498 colns <- c(colns, 499 paste(object$levels[object$labels[i]], 500 "/", object$levels[object$labels[j]], 501 sep = "")) 502 attr(ret2, "decision.values") <- 503 napredict(act, 504 matrix(ret$dec, nrow = nrow(newdata), byrow = TRUE, 505 dimnames = list(rowns, colns) 506 ) 507 ) 508 } 509 510 if (probability && object$type < 2) { 511 if (!object$compprob) 512 warning("SVM has not been trained using `probability = TRUE`, probabilities not available for predictions.") 513 else 514 attr(ret2, "probabilities") <- 515 napredict(act, 516 matrix(ret$prob, nrow = nrow(newdata), byrow = TRUE, 517 dimnames = list(rowns, object$levels[object$labels]) 518 ) 519 ) 520 } 521 522 ret2 523} 524 525print.svm <- 526function (x, ...) 527{ 528 cat("\nCall:", deparse(x$call, 0.8 * getOption("width")), "\n", sep="\n") 529 cat("Parameters:\n") 530 cat(" SVM-Type: ", c("C-classification", 531 "nu-classification", 532 "one-classification", 533 "eps-regression", 534 "nu-regression")[x$type+1], "\n") 535 cat(" SVM-Kernel: ", c("linear", 536 "polynomial", 537 "radial", 538 "sigmoid")[x$kernel+1], "\n") 539 if (x$type==0 || x$type==3 || x$type==4) 540 cat(" cost: ", x$cost, "\n") 541 if (x$kernel==1) 542 cat(" degree: ", x$degree, "\n") 543 if (x$type==1 || x$type==2 || x$type==3) 544 cat(" gamma: ", x$gamma, "\n") 545 if (x$kernel==1 || x$kernel==3) 546 cat(" coef.0: ", x$coef0, "\n") 547 if (x$type==1 || x$type==2 || x$type==4) 548 cat(" nu: ", x$nu, "\n") 549 if (x$type==3) { 550 cat(" epsilon: ", x$epsilon, "\n\n") 551 if (x$compprob) 552 cat("Sigma: ", x$sigma, "\n\n") 553 } 554 555 cat("\nNumber of Support Vectors: ", x$tot.nSV) 556 cat("\n\n") 557 558} 559 560summary.svm <- 561function(object, ...) 562 structure(object, class="summary.svm") 563 564print.summary.svm <- 565function (x, ...) 566{ 567 print.svm(x) 568 if (x$type<2) { 569 cat(" (", x$nSV, ")\n\n") 570 cat("\nNumber of Classes: ", x$nclasses, "\n\n") 571 cat("Levels:", if(is.numeric(x$levels)) "(as integer)", "\n", x$levels) 572 } 573 cat("\n\n") 574 if (x$type==2) cat("\nNumber of Classes: 1\n\n\n") 575 576 if ("MSE" %in% names(x)) { 577 cat(length (x$MSE), "-fold cross-validation on training data:\n\n", sep="") 578 cat("Total Mean Squared Error:", x$tot.MSE, "\n") 579 cat("Squared Correlation Coefficient:", x$scorrcoef, "\n") 580 cat("Mean Squared Errors:\n", x$MSE, "\n\n") 581 } 582 if ("accuracies" %in% names(x)) { 583 cat(length (x$accuracies), "-fold cross-validation on training data:\n\n", sep="") 584 cat("Total Accuracy:", x$tot.accuracy, "\n") 585 cat("Single Accuracies:\n", x$accuracies, "\n\n") 586 } 587 cat("\n\n") 588} 589 590plot.svm <- 591function(x, data, formula = NULL, fill = TRUE, 592 grid = 50, slice = list(), symbolPalette = palette(), 593 svSymbol = "x", dataSymbol = "o", ...) 594{ 595 if (x$type < 3) { 596 if (is.null(formula) && ncol(data) == 3) { 597 formula <- formula(delete.response(terms(x))) 598 formula[2:3] <- formula[[2]][2:3] 599 } 600 if (is.null(formula)) 601 stop("missing formula.") 602 if (fill) { 603 sub <- model.frame(formula, data) 604 xr <- seq(min(sub[, 2]), max(sub[, 2]), length.out = grid) 605 yr <- seq(min(sub[, 1]), max(sub[, 1]), length.out = grid) 606 l <- length(slice) 607 if (l < ncol(data) - 3) { 608 slnames <- names(slice) 609 slice <- c(slice, rep(list(0), ncol(data) - 3 - 610 l)) 611 names <- labels(delete.response(terms(x))) 612 names(slice) <- c(slnames, names[!names %in% 613 c(colnames(sub), slnames)]) 614 } 615 for (i in names(which(vapply(data, is.factor, NA)))) 616 if (!is.factor(slice[[i]])) { 617 levs <- levels(data[[i]]) 618 lev <- if (is.character(slice[[i]])) slice[[i]] else levs[1] 619 fac <- factor(lev, levels = levs) 620 if (is.na(fac)) 621 stop(paste("Level", dQuote(lev), "could not be found in factor", sQuote(i))) 622 slice[[i]] <- fac 623 } 624 625 lis <- c(list(yr), list(xr), slice) 626 names(lis)[1:2] <- colnames(sub) 627 new <- expand.grid(lis)[, labels(terms(x))] 628 preds <- predict(x, new) 629 filled.contour(xr, yr, 630 matrix(as.numeric(preds), 631 nrow = length(xr), byrow = TRUE), 632 plot.axes = { 633 axis(1) 634 axis(2) 635 colind <- as.numeric(model.response(model.frame(x, data))) 636 dat1 <- data[-x$index,] 637 dat2 <- data[x$index,] 638 coltmp1 <- symbolPalette[colind[-x$index]] 639 coltmp2 <- symbolPalette[colind[x$index]] 640 points(formula, data = dat1, pch = dataSymbol, col = coltmp1) 641 points(formula, data = dat2, pch = svSymbol, col = coltmp2) 642 }, 643 levels = 1:(length(levels(preds)) + 1), 644 key.axes = axis(4, 1:(length(levels(preds))) + 0.5, 645 labels = levels(preds), 646 las = 3), 647 plot.title = title(main = "SVM classification plot", 648 xlab = names(lis)[2], ylab = names(lis)[1]), 649 ...) 650 } 651 else { 652 plot(formula, data = data, type = "n", ...) 653 colind <- as.numeric(model.response(model.frame(x, 654 data))) 655 dat1 <- data[-x$index,] 656 dat2 <- data[x$index,] 657 coltmp1 <- symbolPalette[colind[-x$index]] 658 coltmp2 <- symbolPalette[colind[x$index]] 659 points(formula, data = dat1, pch = dataSymbol, col = coltmp1) 660 points(formula, data = dat2, pch = svSymbol, col = coltmp2) 661 invisible() 662 } 663 } 664} 665 666write.svm <- 667function (object, svm.file = "Rdata.svm", scale.file = "Rdata.scale", 668 yscale.file = "Rdata.yscale") 669{ 670 671 ret <- .C (R_svmwrite, 672 ## model 673 as.double (if (object$sparse) object$SV@ra else t(object$SV)), 674 as.integer (nrow(object$SV)), as.integer(ncol(object$SV)), 675 as.integer (if (object$sparse) object$SV@ia else 0), 676 as.integer (if (object$sparse) object$SV@ja else 0), 677 as.double (as.vector(object$coefs)), 678 as.double (object$rho), 679 as.integer (object$compprob), 680 as.double (if (object$compprob) object$probA else 0), 681 as.double (if (object$compprob) object$probB else 0), 682 as.integer (object$nclasses), 683 as.integer (object$tot.nSV), 684 as.integer (object$labels), 685 as.integer (object$nSV), 686 as.integer (object$sparse), 687 688 ## parameter 689 as.integer (object$type), 690 as.integer (object$kernel), 691 as.integer (object$degree), 692 as.double (object$gamma), 693 as.double (object$coef0), 694 695 ## filename 696 as.character(svm.file) 697 698 699 )$ret 700 701 write.table(data.frame(center = object$x.scale$"scaled:center", 702 scale = object$x.scale$"scaled:scale"), 703 file=scale.file, col.names=FALSE, row.names=FALSE) 704 705 if (!is.null(object$y.scale)) 706 write.table(data.frame(center = object$y.scale$"scaled:center", 707 scale = object$y.scale$"scaled:scale"), 708 file=yscale.file, col.names=FALSE, row.names=FALSE) 709} 710 711coef.svm <- function(object, ...) 712{ 713 if (object$kernel != 0 || object$nclasses > 2) 714 stop("Only implemented for regression or binary classification with linear kernel.") 715 ret <- drop(crossprod(object$coefs, object$SV)) 716 trm <- object$terms 717 if(!is.null(trm)) 718 names(ret) <- labels(trm) 719 c(`(Intercept)` = -object$rho, ret) 720} 721