Nothing
context("row_pair_apply")
# require('testthat')
#
# bindFunctionToRowPairs
#
test_that("bindFunctionToRowPairs easy sum", {
data <- cbind(y=c(5,4), x1=c(1,0))
fn1 <- bindFunctionToRowPairs(data, sum)
expected_1_2 <- sum(oneRow(data, 1), oneRow(data, 2))
expect_equal(expected_1_2, fn1(c(1, 2)))
expected_1_1 <- sum(oneRow(data, 1), oneRow(data, 1))
expect_equal(expected_1_1, fn1(c(1, 1)))
expect_equal(4+4, fn1(c(2, 2)))
})
test_that("bindFunctionToRowPairs diff preserve column names", {
data <- cbind(y=c(5,4), x1=c(1,0))
my_diff <- function(row1, row2) row1 - row2
fn1 <- bindFunctionToRowPairs(data, my_diff)
expected_1_2 <- my_diff(oneRow(data, 1), oneRow(data, 2))
out_1_2 <- fn1(c(1, 2))
expect_equal(expected_1_2, out_1_2)
expect_equal(colnames(data), colnames(out_1_2))
})
# TODO: Test row index out of range. Should that live in oneRow?
# pairMatrix
test_that("pairMatrix one column one pair", {
one_row <- matrix(c(1), 1, 1)
out <- pairMatrix(2, function(x) { one_row })
expect_equal(one_row, out)
})
test_that("pairMatrix two columns 3 pairs", {
one_row <- matrix(c(10, 11), 1, 2)
out <- pairMatrix(3, function(x) { one_row })
# 3 * 2 / 2 = 3 rows.
expect_equal(matrix(rep(c(10,11), 3), 3, 2, byrow = TRUE), out)
})
test_that("pairMatrix two columns 3 pairs return row_pair", {
out <- pairMatrix(3, function(row_pair) { matrix(row_pair, 1, 2) })
# 3 * 2 / 2 = 3 rows.
expected_matrix <- rbind(c(1,2), c(1,3), c(2,3))
expect_equal(rbind(c(1,2), c(1,3), c(2,3)), out)
})
test_that("pairMatrix return row_pair", {
out <- pairMatrix(3, function(row_pair) { matrix(row_pair, 1, 2) })
# 3 * 2 / 2 = 3 rows.
expect_equal(rbind(c(1,2), c(1,3), c(2,3)), out)
})
test_that("pairMatrix return row_pair also_reverse_row_pairs", {
out <- pairMatrix(3, function(row_pair) { matrix(row_pair, 1, 2) },
also_reverse_row_pairs=TRUE)
# 3 rows in usual order + 3 rows in reverse order.
# Ideally this test would not care about the order of the rows.
expect_equal(
rbind(c(1,2), c(1,3), c(2,3), c(3,2), c(3,1), c(2,1)), out)
})
test_that("pairMatrix error when not row", {
expect_error(pairMatrix(2, identity),
"pair evaluator function did not return rows")
})
# combineIntoOneFn
test_that("combineIntoOneFn identity once and twice", {
expect_equal(111, identity(111)) # A sanity check
fn_all <- combineIntoOneFn(list(identity))
expect_equal(cbind(out=222), fn_all(222))
fn_all <- combineIntoOneFn(list(identity, identity))
expect_equal(cbind(333, 333), unname(fn_all(333)))
})
test_that("combineIntoOneFn plus functions", {
plusOne <- function(a) return(a+1)
plusTwo <- function(a) return(a+2)
fn_all <- combineIntoOneFn(list(identity, plusOne, plusTwo))
expect_equal(cbind(100, 101, 102), unname(fn_all(100)))
})
test_that("combineIntoOneFn two column functions", {
plusOneAndPlusTwo <- function(a) return(cbind(a+1, a+2))
fn_all <- combineIntoOneFn(list(identity, plusOneAndPlusTwo, identity))
expect_equal(cbind(100, 101, 102, 100), unname(fn_all(100)))
})
test_that("combineIntoOneFn two column function with header", {
plusOneAndPlusTwoWithHeader <- function(a) {
return(cbind(x1=a+1, x2=a+2))
}
# sanity check
expect_equal(cbind(x1=101, x2=102), plusOneAndPlusTwoWithHeader(100))
fn_all <- combineIntoOneFn(list(plusOneAndPlusTwoWithHeader))
expect_equal(cbind(x1=101, x2=102), fn_all(100))
})
#
# heuristicsList
#
test_that("heuristicsList all good", {
model1 <- structure(list(criterion_col=1, cols_to_fit=c(2,3)),
class="model1")
model2 <- structure(list(criterion_col=1, cols_to_fit=c(2,3)),
class=c("model2", "superclass"))
out <- heuristicsList(list(model1, model2), fn=identity)
expect_equal(c(2,3), out$cols_to_fit)
expect_equal(c("model1", "model2"), out$column_names)
})
test_that("heuristicsList mismatched cols_to_fit", {
model1 <- structure(list(criterion_col=1, cols_to_fit=c(2,3)),
class="model1")
model2 <- structure(list(criterion_col=1, cols_to_fit=c(4,5)),
class="model2")
expect_error(heuristicsList(list(model1, model2), fn=identity),
"ERROR: Models with different cols_to_fit: 2, 3 vs. 4, 5")
})
#
# applyFunctionToRowPairs
#
test_that("applyFunctionToRowPairs diff", {
data <- cbind(y=c(5,4,4), x1=c(10,0,0))
diff <- function(row1, row2) row1 - row2
out <- applyFunctionToRowPairs(data, diff)
expect_equal(3, nrow(out))
# applyFunctionToRowPairs should not lose the column names.
expect_equal(c("y", "x1"), colnames(out))
# Row 1 - Row 2
expect_equal(cbind(y=c(1), x1=c(10)), oneRow(out, 1))
# Row 1 - Row 3
expect_equal(cbind(y=c(1), x1=c(10)), oneRow(out, 2))
# Row 2 - Row 2
expect_equal(cbind(y=c(0), x1=c(0)), oneRow(out, 3))
})
test_that("applyFunctionToRowPairs diff data.frame", {
data <- data.frame(y=c(5,4,4), x1=c(10,0,0))
diff <- function(row1, row2) row1 - row2
out <- applyFunctionToRowPairs(data, diff)
expect_equal(3, nrow(out))
# applyFunctionToRowPairs should not lose the column names.
expect_equal(c("y", "x1"), colnames(out))
# Row 1 - Row 2
expect_equal(cbind(y=c(1), x1=c(10)), oneRow(out, 1))
# Row 1 - Row 3
expect_equal(cbind(y=c(1), x1=c(10)), oneRow(out, 2))
# Row 2 - Row 2
expect_equal(cbind(y=c(0), x1=c(0)), oneRow(out, 3))
})
test_that("applyFunctionToRowPairs sum has one-column output", {
data <- cbind(y=c(5,4,4), x1=c(10,0,0))
out <- applyFunctionToRowPairs(data, sum)
expect_equal(3, nrow(out))
expect_equal(c(19), out[1,]) # 5 + 10 + 4 + 0
expect_equal(c(19), out[2,]) # 5 + 10 + 4 + 0
expect_equal( c(8), out[3,]) # 4 + 4 + 0 + 0
})
#
# rowPairApplyList
#
test_that("rowPairApplyList rowIndexes ttb", {
train_matrix <- matrix(c(5,4,1,0,0,1), 2, 3)
ttb <- ttbModel(train_matrix, 1, c(2,3), fit_name="ttb1")
out <- rowPairApplyList(train_matrix, list(rowIndexes(), heuristics(ttb)))
expect_equal(cbind(Row1=c(1), Row2=c(2), ttb1=c(1)), out)
})
test_that("rowPairApplyList rowIndexes ttb also_reverse_row_pairs", {
train_matrix <- matrix(c(5,4,1,0,0,1), 2, 3)
ttb <- ttbModel(train_matrix, 1, c(2,3), fit_name="ttb1")
out <- rowPairApplyList(train_matrix, list(rowIndexes(), heuristics(ttb)),
also_reverse_row_pairs=TRUE)
expect_equal(cbind(Row1=c(1,2), Row2=c(2,1), ttb1=c(1,-1)), out)
})
#
# rowPairApply
#
test_that("rowPairApply ttb test: matrix, 2 rows = 1 pair", {
train_matrix <- matrix(c(5,4,1,0,0,1), 2, 3)
ttb <- ttbModel(train_matrix, 1, c(2,3))
# heuristics
out_1 <- rowPairApply(train_matrix, heuristics(ttb))
# output should look like
# ttbModel
# [1,] 1
expect_equal(cbind(ttbModel=c(1)), out_1)
out_2 <- rowPairApply(train_matrix, heuristics(ttb, ttb))
expected_out2 <- matrix(c(1,1), 1, 2, dimnames=list(NULL, c("ttbModel", "ttbModel")))
# ttbModel ttbModel
# [1,] 1 1
expect_equal(expected_out2, out_2)
# heuristicsProb
out_p1 <- rowPairApply(train_matrix, heuristicsProb(ttb))
# output should look like
# ttbModel
# [1,] 1
expect_equal(cbind(ttbModel=c(1)), out_p1)
out_p2 <- rowPairApply(train_matrix, heuristicsProb(ttb, ttb))
expected_out2 <- matrix(c(1,1), 1, 2, dimnames=list(NULL, c("ttbModel", "ttbModel")))
# ttbModel ttbModel
# [1,] 1 1
expect_equal(expected_out2, out_p2)
})
#TODO: Do this test with a dumber function than ttb.
test_that("rowPairApply dimension test: matrix, 2 rows = 1 pair", {
train_matrix <- cbind(y=c(5,4), x1=c(1,0), x2=c(0,1))
model <- ttbModel(train_matrix, 1, c(2,3))
out1 <- rowPairApply(train_matrix, heuristicsProb(model))
expect_equal(1, nrow(out1))
expect_equal(1, ncol(out1))
out2 <- rowPairApply(train_matrix, heuristicsProb(model, model))
expect_equal(1, nrow(out2))
expect_equal(2, ncol(out2))
})
test_that("rowPairApply dimension test: matrix, 3 rows = 3 pairs", {
train_df <- data.frame(y=c(5,4,3), x1=c(1,0,0), x2=c(0,1,0))
model <- ttbModel(train_df, 1, c(2,3))
out1 <- rowPairApply(train_df, heuristicsProb(model))
expect_equal(3, nrow(out1))
expect_equal(1, ncol(out1))
out2 <- rowPairApply(train_df, heuristicsProb(model, model))
expect_equal(3, nrow(out2))
expect_equal(2, ncol(out2))
})
test_that("rowPairApply dimension test: data.frame", {
train_df <- data.frame(y=c(5,4,3), x1=c(1,0,0), x2=c(0,1,0))
model <- ttbModel(train_df, 1, c(2,3))
out1 <- rowPairApply(train_df, heuristicsProb(model))
expect_equal(3, nrow(out1))
expect_equal(1, ncol(out1))
out2 <- rowPairApply(train_df, heuristicsProb(model, model))
expect_equal(3, nrow(out2))
expect_equal(2, ncol(out2))
})
test_that("rowPairApply dimension test: heuristics, heuristics", {
train_df <- data.frame(y=c(5,4,3), x1=c(1,0,0), x2=c(0,1,0))
model <- ttbModel(train_df, 1, c(2,3))
out1 <- rowPairApply(train_df, heuristicsProb(model))
expect_equal(3, nrow(out1))
expect_equal(1, ncol(out1))
out2 <- rowPairApply(train_df, heuristicsProb(model), heuristicsProb(model))
expect_equal(3, nrow(out2))
expect_equal(2, ncol(out2))
})
test_that("rowPairApply probGreater function dimensions", {
train_df <- data.frame(y=c(5,4,3), x1=c(1,0,0), x2=c(0,1,0))
out1 <- rowPairApply(train_df, probGreater(1))
expect_equal(3, nrow(out1))
expect_equal(1, ncol(out1))
out2 <- rowPairApply(train_df, probGreater(1), probGreater(1))
expect_equal(3, nrow(out2))
expect_equal(2, ncol(out2))
})
test_that("rowPairApply probGreater greater", {
train_df <- data.frame(y=c(9,5))
out <- rowPairApply(train_df, probGreater(1))
expect_equal(c(ProbGreater=1), out[1,1])
})
test_that("rowPairApply probGreater same", {
train_df <- data.frame(y=c(5,5))
out <- rowPairApply(train_df, probGreater(1))
expect_equal(c(ProbGreater=0.5), out[1,1])
})
test_that("rowPairApply probGreater less", {
train_df <- data.frame(y=c(5,9))
out <- rowPairApply(train_df, probGreater(1))
expect_equal(c(ProbGreater=0), out[1,1])
})
test_that("rowPairApply correctGreater function dimensions", {
train_df <- data.frame(y=c(5,4,3), x1=c(1,0,0), x2=c(0,1,0))
out1 <- rowPairApply(train_df, correctGreater(1))
expect_equal(3, nrow(out1))
expect_equal(1, ncol(out1))
out2 <- rowPairApply(train_df, correctGreater(1), correctGreater(1))
expect_equal(3, nrow(out2))
expect_equal(2, ncol(out2))
})
test_that("rowPairApply correctGreater greater", {
train_df <- data.frame(y=c(9,5))
out <- rowPairApply(train_df, correctGreater(1))
expect_equal(c(CorrectGreater=1), out[1,1])
})
test_that("rowPairApply correctGreater same", {
train_df <- data.frame(y=c(5,5))
out <- rowPairApply(train_df, correctGreater(1))
expect_equal(c(CorrectGreater=0), out[1,1])
})
test_that("rowPairApply correctGreater less", {
train_df <- data.frame(y=c(5,9))
out <- rowPairApply(train_df, correctGreater(1))
expect_equal(c(CorrectGreater=-1), out[1,1])
})
test_that("rowPairApply rowIndexes function", {
train_df <- data.frame(y=c(5,4,3), x1=c(1,0,0), x2=c(0,1,0))
model <- ttbModel(train_df, 1, c(2,3))
out1 <- rowPairApply(train_df, rowIndexes())
expect_equal(3, nrow(out1))
expect_equal(2, ncol(out1))
out2 <- rowPairApply(train_df, rowIndexes(), rowIndexes())
expect_equal(3, nrow(out2))
expect_equal(4, ncol(out2))
})
test_that("rowPairApply colPairValues function numeric", {
train_df <- data.frame(y=c(5,4,3), x1=c(1,0,0), x2=c(0,1,0))
model <- ttbModel(train_df, 1, c(2,3))
# colPairValues outputs 2 columns
out1 <- rowPairApply(train_df, colPairValues(1, "a"))
expect_equal(3, nrow(out1))
expect_equal(2, ncol(out1))
out2 <- rowPairApply(train_df, colPairValues(1, "a"),
colPairValues(1, "b"))
expect_equal(3, nrow(out2))
expect_equal(4, ncol(out2))
})
test_that("rowPairApply heuristics with fn", {
train_matrix <- cbind(y=c(5,4), x1=c(1,1))
model <- ttbModel(train_matrix, 1, c(2))
# Using heuristicsList.
out <- rowPairApply(train_matrix,
heuristicsList(list(model), fn=predictProbInternal),
heuristicsList(list(model), fn=predictPairInternal))
# predictProbInternal guesses wtih 0.5. predictPairInternal guesses with 0.
expect_equal(cbind(0.5, 0), unname(out))
# Using the shortcut wrappers, heuristicsProb and heuristics.
out2 <- rowPairApply(train_matrix, heuristicsProb(model),
heuristics(model))
expect_equal(cbind(0.5, 0), unname(out))
})
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.