tests/testthat/test-balanceTable.R

In matchMulti: Optimal Multilevel Matching using a Network Algorithm

# library(matchMulti)
# library( testthat )

context("balance tables")

data(minischool)



student.cov <- c('mathach', 'minority', 'female')

# Does school.fb work?
minischool = dplyr::mutate( minischool,
                            size_cut = cut( size, 2 ),
                            discrm_cut = cut( discrm, 2 ) )

nrow( minischool )
table(  minischool$sector, minischool$school  )


school.fb <- c( "discrm_cut", "size_cut" )
school.cov = c( "discrm", "size" )


##### Check balance on raw data ######

bt <- balanceTable( minischool, 
                    treatment = "sector",
                    school.id = "school",
                    var.names = c( student.cov, school.cov ),
                    include.tests = TRUE )
bt



btNt <- balanceTable( minischool, 
                      treatment = "sector",
                      var.names = c( student.cov, school.cov ),
                      include.tests = FALSE )
btNt

expect_true( nrow( btNt ) == 5 )
expect_true( all( btNt$`Treated Mean` == bt$`Treated Mean` ) )
expect_true( all( btNt$`Control Mean` == bt$`Control Mean` ) )
expect_true( all( btNt$SDiff == bt$SDiff ) )



# Are we getting balance on categorical levels?
btN <- balanceTable( minischool, 
                     treatment = "sector",
                     include.tests = FALSE )
btN
# We should see multiple discrm_cut and size_cuts 

expect_true( nrow(btN) > ncol(minischool) )



fakedbl = balanceTable( minischool, df.match=minischool, 
                        treatment = "sector", school.id = "school", 
                        var.names = c( "minority", "discrm_cut" ),
                        include.tests = TRUE )
fakedbl
expect_true( all( fakedbl$`After Agg PValue` == fakedbl$`Before Agg PValue` ))



##### Now do matching and check balance ######

 
match.simpleA <- matchMulti(minischool, treatment = 'sector',
                            school.id = 'school', match.students = FALSE,
                            school.fb = school.fb )
match.simpleA



test_that( "balanceMulti works", {
  
  btab_split = balanceMulti( match.simpleA,
                             school.cov = school.cov, 
                             student.cov = student.cov )
  btab_split
  
  expect_true( nrow( btab_split$schools ) == 2 )
  expect_true( nrow( btab_split$students ) == 3 )
} )



test_that( "single.table works", {
  
  btab = balanceMulti( match.simpleA, single.table = TRUE, include.tests = TRUE )
  btab
  
  btab2 = balanceMulti( match.simpleA, single.table = TRUE, include.tests = FALSE )
  btab2
  
  expect_equal( nrow(btab), nrow(btab2) )
  expect_equal( dim(btab2), c( 14, 6 ) )
  
} )




#### Testing weights for balance tables #####



# test_that( "weights work (Basic tests)", {
#   
#   ns = table( minischool$sector )
#   ns
#   
#   bt <- expect_error( balanceTable( minischool, 
#                                     treatment = "sector",
#                                     school.id = "school",
#                                     var.names = c( student.cov, school.cov ),
#                                     treat.wts = runif( 1,5, ns[[2]] ),
#                                     include.tests = TRUE )
#   )
#   
#   bt <- balanceTable( minischool, 
#                       treatment = "sector",
#                       school.id = "school",
#                       var.names = c( student.cov, school.cov ),
#                       treat.wts = runif( ns[[2]], 1,5 ),
#                       ctrl.wts = runif( ns[[1]], 1,5 ),
#                       include.tests = TRUE )
#   
#   bt
#   expect_true( all( !is.na( bt$`Agg PValue` ) ) )
#   expect_true( all( is.na( bt$`CRVE PValue` ) ) )
#   
#   bt <- balanceTable( minischool, 
#                       treatment = "sector",
#                       school.id = "school",
#                       var.names = c( student.cov, school.cov ),
#                       treat.wts = rep( 1, ns[[2]] ),
#                       ctrl.wts = rep( 2, ns[[1]] ),
#                       include.tests = TRUE )
#   
#   bt
#   expect_true( all( !is.na( bt$`Agg PValue` ) ) )
#   expect_true( all( !is.na( bt$`CRVE PValue` ) ) )
#   
# } )