tests/testthat/test-TSVM.R

In RSSL: Implementations of Semi-Supervised Learning Approaches for Classification

context("Transductive SVM")

X <- matrix(c(0,0.001,1,-1),nrow=2)
X_u <- matrix(c(-1,-1,-1,0,0,0,-0.4,-0.5,-0.6,1.2,1.3,1.25),ncol=2)
y <- factor(c(-1,1))
ynum <- factor_to_dummy(y)[1,]

g_lin <- LinearTSVM(X=X,y=y,X_u=X_u,C=1,Cstar=1,x_center=TRUE)
g_constraint <- TSVM(X=X,y=y,X_u=X_u,C=1,Cstar=1,
                     balancing_constraint = TRUE,x_center=TRUE)
g_noconstraint <- TSVM(X=X,y=y,X_u=X_u,C=1,Cstar=1,
                       balancing_constraint = FALSE,x_center=TRUE)

test_that("TSVM equal to SVM if Cstar is near zero",{
  # Note the balancing_constraint=FALSE for this to work.
  g_sup <- LinearSVM(X=X,y=y,C=1,scale=FALSE)
  
  g_semi <- LinearTSVM(X=X,y=y,X_u=X_u,C=1,Cstar=0,x_center=FALSE)
  expect_equal(g_sup@w,g_semi@w,tolerance=1e-4)
  expect_equal(decisionvalues(g_sup,X_u),decisionvalues(g_semi,X_u),tolerance=1e-4)
  
  # g_sup <- SVM(X=X,y=y,C=1,scale=FALSE)
  # g_semi <- TSVM(X=X,y=y,X_u=X_u,C=1,Cstar=0.001,x_center=FALSE,balancing_constraint = FALSE)
  # expect_equal(decisionvalues(g_sup,X_u),decisionvalues(g_semi,X_u),tolerance=10e-3)
  
  # g_sup <- SVM(X=X,y=y,C=10000,kernel=kernlab::rbfdot(1),scale=FALSE)
  # g_semi <- TSVM(X=X,y=y,X_u=X_u,C=10000,Cstar=0.003,kernel=kernlab::rbfdot(1),x_center=FALSE,verbose=FALSE,balancing_constraint = FALSE)
  # expect_equal(decisionvalues(g_sup,X_u),decisionvalues(g_semi,X_u),tolerance=10e-3)
  
})

test_that("Example gives same result for Linear and Kernel implementation",{

  w1 <- g_constraint@alpha %*% rbind(X,X_u,X_u,colMeans(X_u))
  w2 <- c(g_noconstraint@bias, 
          g_noconstraint@alpha %*% rbind(X,X_u,X_u))
  w3 <- g_lin@w
  expect_equal(w2,w3,tolerance=10e-5)
})

test_that("Prediction works", {
  decisionvalues(g_constraint,X_u)
  predict(g_constraint,X_u)
  expect_equal(decisionvalues(g_noconstraint,X_u),
               decisionvalues(g_lin,X_u),tolerance=10e-5)
})

test_that("Gradient of TSVM CCCP linear is superficially correct.",{
  for (i in 1:10) {
    w_1 <- runif(2)
    w_2 <- runif(2)
    expect_equal(tsvm_cccp_lin_gradient(w_1,w_2,X,X_u,y=ynum,y_u=rep(c(-1,1),each=nrow(X_u)),
                                        s=0,C=1,Cstar=0.1),
                  numDeriv::grad(tsvm_cccp_lin_objective,w_1,w_now=w_2,X=X,X_u=X_u,y=ynum,
                                 y_u=rep(c(-1,1),each=nrow(X_u)),C=1,Cstar=0.1)
    )
  }
})

test_that("Adaptable hinge loss",{
  expect_equal(hs(c(100,1.5,0.5,-0.5),s=1),c(0,0,0.5,1.5))
})