Nothing
context("aggregators")
# require('testthat')
#
# heuristicsListGroupedByColsToFit
#
test_that("heuristicsListGroupedByColsToFit all in one", {
m1 <- structure(list(criterion_col=1, cols_to_fit=c(2,3)),
class="m1")
m2 <- structure(list(criterion_col=1, cols_to_fit=c(2,3)),
class="m2")
out <- heuristicsListGroupedByColsToFit(list(m1, m2))
expect_equal(1, length(out))
expect_equal(c(2,3), out[[1]]$cols_to_fit)
expect_equal(c("m1","m2"), out[[1]]$column_names)
})
test_that("heuristicsListGroupedByColsToFit group in two", {
m1 <- structure(list(criterion_col=1, cols_to_fit=c(2,3)),
class="m1")
m2 <- structure(list(criterion_col=1, cols_to_fit=c(2,3)),
class="m2")
m3 <- structure(list(criterion_col=1, cols_to_fit=c(3)),
class="m3")
out <- heuristicsListGroupedByColsToFit(list(m1, m2, m3))
expect_equal(2, length(out))
expect_equal(c(2,3), out[[1]]$cols_to_fit)
expect_equal(c("m1","m2"), out[[1]]$column_names)
expect_equal(c(3), out[[2]]$cols_to_fit)
expect_equal(c("m3"), out[[2]]$column_names)
})
test_that("heuristicsListGroupedByColsToFit group separate but keep order", {
m1 <- structure(list(criterion_col=1, cols_to_fit=c(2,3)),
class="m1")
m2 <- structure(list(criterion_col=1, cols_to_fit=c(2,3)),
class="m2")
m3 <- structure(list(criterion_col=1, cols_to_fit=c(3)),
class="m3")
m4 <- structure(list(criterion_col=1, cols_to_fit=c(2,3)),
class="m4")
out <- heuristicsListGroupedByColsToFit(list(m1, m2, m3, m4))
expect_equal(3, length(out))
expect_equal(c(2,3), out[[1]]$cols_to_fit)
expect_equal(c("m1","m2"), out[[1]]$column_names)
expect_equal(c(3), out[[2]]$cols_to_fit)
expect_equal(c("m3"), out[[2]]$column_names)
expect_equal(c(2,3), out[[3]]$cols_to_fit)
expect_equal(c("m4"), out[[3]]$column_names)
})
#
# percentCorrectListReturnMatrix
#
test_that("percentCorrectListReturnMatrix mismatched criterion", {
data <- cbind(y=c(30,20,10,5), x1=c(1,1,0,0), x2=c(1,1,0,1))
model1 <- structure(list(criterion_col=1, cols_to_fit=c(3)),
class="model1")
model2 <- structure(list(criterion_col=2, cols_to_fit=c(3)),
class="model2")
# The error message actually comes from heuristicsList.
expect_error(percentCorrectListReturnMatrix(data, list(model1, model2)),
"ERROR: Models with different criterion_col: 1 vs. 2")
})
test_that("percentCorrectListReturnMatrix mismatched cols_to_fit", {
data <- cbind(y=c(30,20,10,5), x1=c(1,1,0,0), x2=c(1,1,0,1))
ttb_2_3 <- ttbModel(data, 1, c(2,3), fit_name="ttb_2_3")
ttb_2 <- ttbModel(data, 1, c(2), fit_name="ttb_2")
out <- percentCorrectListReturnMatrix(data, list(ttb_2_3, ttb_2))
expect_equal(c("ttb_2_3", "ttb_2"), colnames(out))
})
#
# tests for -1 bug
#
test_that("rowPairApply ProbGreater -1 bug", {
# Specify enough of a ttb model for prediction.
fitted_ttb <- structure(list(criterion_col=1, cols_to_fit=c(2:4),
linear_coef=c(4,2,1)),
class="ttbModel")
# Below are rows from the fish fertility data set where we uncovered this bug.
test_data <- data.frame(criterion=c(33200, 36184), a=c(5,3),
b=c(976,1437), c=c(50, 49.74))
results <- rowPairApplyList(test_data,
list(heuristics(fitted_ttb), probGreater(1)))
expect_equal(cbind(ttbModel=c(1), ProbGreater=c(0)), results)
})
test_that("percentCorrectList -1 prediction bug", {
# Specify enough of a ttb model for prediction.
fitted_ttb <- structure(list(criterion_col=1, cols_to_fit=c(2:4),
linear_coef=c(4,2,1)),
class="ttbModel")
test_data <- data.frame(criterion=c(33200, 36184), a=c(5,3), b=c(976,1437),
c=c(50, 49.74))
results <- percentCorrectListReturnMatrix(test_data, list(fitted_ttb))
expect_equal(cbind(ttbModel=c(0)), results)
})
test_that("percentCorrectList -1 prediction bug reverse rows", {
# Specify enough of a ttb model for prediction.
fitted_ttb <- structure(list(criterion_col=1, cols_to_fit=c(2:4),
linear_coef=c(4,2,1)),
class="ttbModel")
test_data <- data.frame(criterion=rev(c(33200, 36184)), a=rev(c(5,3)),
b=rev(c(976,1437)), c=rev(c(50, 49.74)))
results <- percentCorrectListReturnMatrix(test_data, list(fitted_ttb))
expect_equal(cbind(ttbModel=c(0)), results)
})
# test_that("end to end test ttb vs. logistic regression input matrix", {
# train_data <- cbind(y=c(5,4,3), x1=c(1,0,0))
# ttb <- ttbModel(train_data, 1, c(2))
# lreg <- logRegModel(train_data, 1, c(2))
# pred <- rowPairApplyList(
# train_data, list(rowIndexes(), heuristics(ttb, lreg), correctGreater(1)))
# pred_df <- as.data.frame(pred)
#
# row <- pred_df[which(pred_df$Row1==1 && pred_df$Row2==2),]
# expect_equal(1, row$ttbModel, tolerance=0.001)
# expect_equal(1, row$logRegModel, tolerance=0.001)
# row <- pred_df[which(pred_df$Row1==2),]
# # Below are guesses, which means output of 0 for predictPair.
# expect_equal(0, row$ttbModel, tolerance=0.001)
# expect_equal(0, row$logRegModel, tolerance=0.001)
# expect_equal(3, nrow(pred_df))
#
# pct_correct_df <- percentCorrectList(train_data, list(ttb, lreg))
# #expect_equal(c("ttbModel", "logRegModel"), names(pct_correct_df))
# expect_equal(83.33, pct_correct_df$ttbModel, tolerance=0.001)
# expect_equal(83.33, pct_correct_df$logRegModel, tolerance=0.001)
# expect_equal(1, nrow(pct_correct_df))
# })
# predictPairSummary
test_that("predictPairSummary 1 model", {
data <- cbind(y=c(5,4,3), x1=c(1,0,0), x2=c(1,0,1))
ttb <- ttbModel(data, 1, c(2:3))
out <- predictPairSummary(data, ttb)
expect_equal(cbind(Row1=c(1), Row2=c(2), CorrectGreater=c(1), ttbModel=c(1)),
oneRow(out, 1))
expect_equal(cbind(Row1=c(1), Row2=c(3), CorrectGreater=c(1), ttbModel=c(1)),
oneRow(out, 2))
expect_equal(cbind(Row1=c(2), Row2=c(3), CorrectGreater=c(1), ttbModel=c(0)),
oneRow(out, 3))
})
test_that("predictPairSummary 3 models", {
data <- cbind(y=c(5,4,3), x1=c(1,0,0), x2=c(1,0,1))
ttb <- ttbModel(data, 1, c(2:3))
ttbG <- ttbGreedyModel(data, 1, c(2:3))
reg <- regModel(data, 1, c(2:3))
out <- predictPairSummary(data, ttb, ttbG, reg)
expect_equal(cbind(Row1=c(1), Row2=c(2), CorrectGreater=c(1), ttbModel=c(1),
ttbGreedyModel=c(1), regModel=c(1)), oneRow(out, 1))
expect_equal(cbind(Row1=c(1), Row2=c(3), CorrectGreater=c(1), ttbModel=c(1),
ttbGreedyModel=c(1), regModel=c(1)), oneRow(out, 2))
expect_equal(cbind(Row1=c(2), Row2=c(3), CorrectGreater=c(1), ttbModel=c(0),
ttbGreedyModel=c(1), regModel=c(-1)), oneRow(out, 3))
})
test_that("predictPairSummary custom model fit_name", {
data <- cbind(y=c(5,4,3), x1=c(1,0,0), x2=c(1,0,1))
ttb <- ttbModel(data, 1, c(2:3), reverse_cues=FALSE, fit_name="ttbNoRev")
out <- predictPairSummary(data, ttb)
expect_equal(colnames(out), c('Row1', 'Row2', 'CorrectGreater', 'ttbNoRev'))
})
# percentCorrect and related functions
## The function below works locally but fails in Travis with an error deep
## inside a which function.
# test_that("end to end test ttb vs. logistic regression input data.frame", {
# train_df <- data.frame(y=c(5,4,3), x=c(1,0,0), name=c("jo", "bo", "da"))
# ttb <- ttbModel(train_df, 1, c(2))
# lreg <- logRegModel(train_df, 1, c(2))
# pred <- rowPairApplyList(
# train_df, list(rowIndexes(), heuristics(ttb, lreg), correctGreater(1)))
# pred_df <- data.frame(pred)
#
# row <- pred_df[which(pred_df$Row1==1 && pred_df$Row2==2),]
# expect_equal(1, row$ttbModel, tolerance=0.001)
# expect_equal(1, row$logRegModel, tolerance=0.001)
# row <- pred_df[which(pred_df$Row1==2),]
# expect_equal(0, row$ttbModel, tolerance=0.001)
# expect_equal(0, row$logRegModel, tolerance=0.001)
# expect_equal(3, nrow(pred_df))
#
# pct_correct_df <- percentCorrectList(train_df, list(ttb, lreg))
# expect_equal(83.33, pct_correct_df$ttbModel, tolerance=0.01)
# expect_equal(83.33, pct_correct_df$logRegModel, tolerance=0.01)
# expect_equal(1, nrow(pct_correct_df))
# })
# Warning: This test is NOT self-contained. It relies on the provided
# city_population data set.
test_that("city_population ttb vs. regression on dirty four cities", {
ttb <- ttbModel(city_population, 3, c(4:ncol(city_population)))
reg <- regModel(city_population, 3, c(4:ncol(city_population)))
pct_correct_df <- percentCorrectList(city_population[c(27,30,52,68),],
list(ttb, reg))
expect_equal(0, pct_correct_df$ttbModel, tolerance=0.001)
expect_equal(0, pct_correct_df$regModel, tolerance=0.001)
# Confirm same results even with a different order of rows.
pct_correct_df <- percentCorrectList(city_population[c(68,52,30,27),],
list(ttb, reg))
expect_equal(0, pct_correct_df$ttbModel, tolerance=0.001)
expect_equal(0, pct_correct_df$regModel, tolerance=0.001)
# ttb and reg are symmetric, so everything is the same with
# percentCorrectListNonSymmetric
pct_correct_df <- percentCorrectListNonSymmetric(
city_population[c(27,30,52,68),], list(ttb, reg))
expect_equal(0, pct_correct_df$ttbModel, tolerance=0.001)
expect_equal(0, pct_correct_df$regModel, tolerance=0.001)
})
test_that("percentCorrectList vs percentCorrect", {
# This uses all1Model, not exported from aggregators. Find a better way.
data <- cbind(y=c(4,3,2,1), x1=c(1, 1, 0, 0))
expect_equal(
percentCorrectList(data, list(fitted_always_1)),
percentCorrect(data, fitted_always_1))
expect_equal(
percentCorrectList(data, list(fitted_always_1, fitted_always_1)),
percentCorrect(data, fitted_always_1, fitted_always_1))
})
test_that("percentCorrectList vs percentCorrectListNonSymmetric", {
# This uses all1Model, not exported from aggregators. Find a better way.
data <- cbind(y=c(4,3,2,1), x1=c(1, 1, 0, 0))
# percentCorrectList incorrectly says this gets it all right.
# It is incorrect because it assumes the heuristic makes symmetric
# decisions: if it chooses A > B, it will chose B < A, so the function
# only checks the former of those two cases.
pct_correct_df <- percentCorrectList(data, list(fitted_always_1))
expect_equal(100, pct_correct_df$all1Model, tolerance=0.001)
# percentCorrectListNonSymmetric does not assume symmetry and so
# correctly says this heuristic is 50% correct.
pct_correct_df <- percentCorrectListNonSymmetric(data, list(fitted_always_1))
expect_equal(50, pct_correct_df$all1Model, tolerance=0.01)
})
test_that("percentCorrectList vs percentCorrectListNonSymmetric", {
expect_error(percentCorrectList(data, fitted_always_1),
"Second argument to percentCorrectList should be list but got all1Model")
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.