tests/testthat/test-aggregate.R

In COINr: Composite Indicator Construction and Analysis

test_that("agg_df", {

  # test data frame, 5 cols 20 rows
  X <- as.data.frame(matrix(runif(100), 20, 5))

  # test default - means of rows
  Xag <- Aggregate(X)
  expect_equal(Xag, rowMeans(X))

  # try passing some weights
  Xag <- Aggregate(X, f_ag = "a_amean", f_ag_para = list(w = 1:5))

  # repeat manually
  Xag2 <- apply(X, 1, weighted.mean, 1:5)
  expect_equal(Xag, Xag2)

  # test data threshold
  X_NAs <- X
  # set first row to have 4/5 NAs
  X_NAs[1, 1:4] <- NA
  # aggregate (same as last time)
  XagNA <- Aggregate(X_NAs, f_ag = "a_amean", f_ag_para = list(w = 1:5), dat_thresh = 0.5)
  # check first one is NA
  expect_equal(XagNA[1], as.numeric(NA))
  # check rest are the same
  expect_equal(XagNA[-1], Xag[-1])

})

test_that("agg_coin", {

  # build example coin up to normalised dset
  coin <- build_example_coin(up_to = "Normalise", quietly = TRUE)

  # the objective here will be to check that the aggregation follows the weights
  # and the structure
  # To check this properly we'll have to change the weights, since at the moment all equal
  coin$Meta$Weights$Alt <- coin$Meta$Weights$Original
  coin$Meta$Weights$Alt$Weight <- runif(nrow(coin$Meta$Weights$Alt))

  # now aggregate
  coin <- Aggregate(coin, dset = "Normalised", w = "Alt")

  # extract normalised dset
  Xnorm <- get_dset(coin, "Normalised")
  # extract aggregated dset (via coin method)
  Xagg <- get_dset(coin, "Aggregated")

  # NOW we have to repeat manually - this will be slightly fiddly
  # the starting point is the normalised data set
  Xagg2 <- Xnorm

  # get lineage
  lin <- coin$Meta$Lineage
  # get weights
  ws <- coin$Meta$Weights$Alt

  # aggregate each pillar manually
  pcodes <- unique(lin$Pillar)
  for(pcode in pcodes){
    # ind codes
    icodes <- lin$Indicator[lin$Pillar == pcode]
    # get inds
    X <- Xagg2[icodes]
    # get weights
    w <- ws$Weight[match(icodes, ws$iCode)]
    # aggregate
    Xagg2 <- cbind(Xagg2, Aggregate(X, f_ag = "a_amean", f_ag_para = list(w = w)))
    # rename
    names(Xagg2)[ncol(Xagg2)] <- pcode
  }

  # aggregate each sub-pillar manually
  pcodes <- unique(lin$`Sub-index`)
  for(pcode in pcodes){
    # ind codes
    icodes <- unique(lin$Pillar[lin$`Sub-index` == pcode])
    # get inds
    X <- Xagg2[icodes]
    # get weights
    w <- ws$Weight[match(icodes, ws$iCode)]
    # aggregate
    Xagg2 <- cbind(Xagg2, Aggregate(X, f_ag = "a_amean", f_ag_para = list(w = w)))
    # rename
    names(Xagg2)[ncol(Xagg2)] <- pcode
  }

  # aggregate to index
  # ind codes
  icodes <- unique(lin$`Sub-index`)
  # get inds
  X <- Xagg2[icodes]
  # get weights
  w <- ws$Weight[match(icodes, ws$iCode)]
  # aggregate
  Xagg2 <- cbind(Xagg2, Aggregate(X, f_ag = "a_amean", f_ag_para = list(w = w)))
  # rename
  names(Xagg2)[ncol(Xagg2)] <- "Index"

  # COMPARE
  # make sure col orderings are the same
  Xagg2 <- Xagg2[names(Xagg)]

  # CHECK
  expect_equal(Xagg, Xagg2)

})

test_that("agg_purse", {

  # purse
  purse <- build_example_purse(up_to = "Normalise", quietly = TRUE)

  # aggregate via coin method
  coin1 <- Aggregate(purse$coin[[1]], dset = "Normalised")

  # aggregate via purse method
  purse <- Aggregate(purse, dset = "Normalised")

  # check
  expect_equal(purse$coin[[1]]$Data$Aggregated, coin1$Data$Aggregated)
})

test_that("agg_functions", {

  # geometric
  x <- c(1, 2, 3)
  yg <- a_gmean(x)

  expect_equal(yg, (1*2*3)^(1/3))
  expect_error(a_gmean(c(1, 2, -1)))
  expect_error(a_gmean(c(1, 2, 0)))

  yg2 <- a_gmean(x, c(1,1,2))
  expect_equal(yg2, (1*2*3^2)^(1/4))

  # harmonic
  x <- c(1, 2, 3)
  yh <- a_hmean(x, c(2, 1, 1))
  expect_equal(yh, 4/(2/1 + 1/2 + 1/3))

  # generalised
  ygen <- a_genmean(x, c(2,1,1), p = -1)
  expect_equal(ygen, yh)
  ygen <- a_genmean(x, p = 1)
  expect_equal(ygen, 2) # simple arithmetic av.

})

test_that("outranking", {

  # a df
  X <- data.frame(
    x1 = 1:4,
    x2 = c(3:1, 5),
    x3 = c(2,3,1, 4)
  )

  orm <- outrankMatrix(X)

  expect_equal(nrow(orm$OutRankMatrix), 4)
  expect_equal(ncol(orm$OutRankMatrix), 4)

  # check some scores
  expect_equal(diag(orm$OutRankMatrix), c(0,0,0,0))
  expect_equal(orm$OutRankMatrix[2,1], 2/3)
  expect_equal(orm$OutRankMatrix[3,1], 1/3)
  expect_equal(orm$OutRankMatrix[4,1], 1)
  expect_equal(orm$nDominant, 3)
  expect_equal(orm$fracDominant, 3/6)

})

test_that("copeland", {

  # a df
  X <- data.frame(
    x1 = 1:4,
    x2 = c(3:1, 5),
    x3 = c(2,3,1, 4)
  )

  y <- a_copeland(X)

  orm <- outrankMatrix(X)$OutRankMatrix
  orm[orm > 0.5] <- 1
  orm[orm < 0.5] <- -1
  orm[orm == 0.5] <- 0
  diag(orm) <- 0

  expect_equal(y, rowSums(orm))

  # test equal units correctly assigned
  X <- data.frame(
    x1 = c(1,2),
    x2 = c(2,1)
  )

  orm <- outrankMatrix(X)$OutRankMatrix
  expect_equal(orm[1,2], 0.5)
  expect_equal(orm[2,1], 0.5)

  y <- a_copeland(X)
  expect_equal(y, c(0,0))

})

test_that("aggregation by level", {

  coin <- build_example_coin(up_to = "new_coin")

  # Testing:
  # - different aggregation functions by level
  # - different parameter sets by level
  # - passing vectors or data frames to functions at different levels
  # note: silly_aggregate is a function in utils.R
  coin <- Aggregate(coin, dset = "Raw", f_ag = c("a_amean", "a_gmean", "silly_aggregate"),
                    f_ag_para = list(NULL, NULL, list(start_at = 10)), by_df = c(FALSE, FALSE, TRUE)
                    )

  # check results
  X <- get_dset(coin, dset = "Aggregated")

  imeta <- coin$Meta$Ind

  # test lev 1 to 2
  imeta_grp <- imeta[which(imeta$Parent == "Physical"), ]
  x <- X[1, imeta_grp$iCode] |> as.numeric()
  y <- a_amean(x, w = imeta_grp$Weight)
  expect_equal(X[1, "Physical"], y)

  # test lev 2 to 3
  imeta_grp <- imeta[which(imeta$Parent == "Conn"), ]
  x <- X[1, imeta_grp$iCode] |> as.numeric()
  y <- a_gmean(x, w = imeta_grp$Weight)
  expect_equal(X[1, "Conn"], y)

  # test lev 3 to 4
  expect_equal(X[["Index"]], 10:(nrow(X) + 9))


  # Now test using different weight specs at different levels
  coin <- Aggregate(coin, dset = "Raw", f_ag = c("a_amean", "silly_aggregate_no_wts", "silly_aggregate"),
                    f_ag_para = list(NULL, NULL, list(start_at = 10)), by_df = c(FALSE, TRUE, TRUE), w = list(NULL, "none", NULL))

  # check results
  X <- get_dset(coin, dset = "Aggregated")

  # test lev 1 to 2
  imeta_grp <- imeta[which(imeta$Parent == "Physical"), ]
  x <- X[1, imeta_grp$iCode] |> as.numeric()
  y <- a_amean(x, w = imeta_grp$Weight)
  expect_equal(X[1, "Physical"], y)

  # test lev 2 to 3: expect the Conn group to be aggregated as simply the first indicator
  imeta_grp <- imeta[which(imeta$Parent == "Conn"), ]
  expect_equal(X[["Conn"]], X[[imeta_grp$iCode[1]]])

  # test lev 3 to 4
  expect_equal(X[["Index"]], 10:(nrow(X) + 9))

})

# test passing no weights to aggregation function...
test_that("sum_by_level", {

  coin <- build_example_coin(up_to = "new_coin")

  # test as sum of indicators in each group (weights NOT passed)
  coin <- Aggregate(coin, dset = "Raw", f_ag = "sum",
                    f_ag_para = list(na.rm = TRUE), w = "none"
  )

  # checks - pick a selected value
  CHN_phys <- get_data(coin, dset = "Aggregated", iCodes = "Physical", Level = 2, uCodes = "CHN", also_get = "none") |>
    as.numeric()

  CHN_phys_man <- get_data(coin, dset = "Raw", iCodes = "Physical", Level = 1, uCodes = "CHN", also_get = "none") |>
    as.numeric() |>
    sum(na.rm = TRUE)

  expect_equal(CHN_phys, CHN_phys_man)

  # another
  IND_conn <- get_data(coin, dset = "Aggregated", iCodes = "Conn", Level = 3, uCodes = "IND", also_get = "none") |>
    as.numeric()

  IND_conn_man <- get_data(coin, dset = "Aggregated", iCodes = "Conn", Level = 2, uCodes = "IND", also_get = "none") |>
    as.numeric() |>
    sum(na.rm = TRUE)

  expect_equal(IND_conn, IND_conn_man)

})