tests/testthat/test-schur.R

In stla/jackR: Jack, Zonal, Schur, and Other Symmetric Polynomials

test_that(
  # https://math.stackexchange.com/questions/3335885/expansion-of-sum-x-in-in-schur-polynomials
  "Schur expansion of (sum x_i)^n", {
    # numeric
    x <- c(3,4,5,6)
    e <- SchurR(x, c(4)) + 3*SchurR(x, c(3,1)) + 2*SchurR(x, c(2,2)) +
      3*SchurR(x, c(2,1,1)) + SchurR(x, c(1,1,1,1))
    expect_equal(e, sum(x)^4)
    # gmp
    x <- as.bigq(c(3L,4L,5L,6L), c(4L,5L,6L,7L))
    e <- SchurR(x, c(4)) + 3L*SchurR(x, c(3,1)) + 2L*SchurR(x, c(2,2)) +
      3L*SchurR(x, c(2,1,1)) + SchurR(x, c(1,1,1,1))
    expect_identical(e, sum(x)^4)
    # polynomial
    n <- 4
    P <- SchurPolR(n, c(4)) + 3*SchurPolR(n, c(3, 1)) + 2*SchurPolR(n, c(2, 2)) +
      3*SchurPolR(n, c(2, 1, 1)) + SchurPolR(n, c(1, 1, 1, 1))
    Q <- (mvp("x_1", 1, 1) + mvp("x_2", 1, 1) + mvp("x_3", 1, 1) +
            mvp("x_4", 1, 1))^4
    expect_true(as_mvp_qspray(P) == Q)
  }
)

test_that(
  "Schur = 0 if l(lambda)>l(x)", {
    # numeric
    expect_equal(SchurR(c(1,2), c(3,2,1)), 0)
    expect_equal(SchurR(c(1,2), c(3,2,1), algorithm = "naive"), 0)
    # gmp
    x <- as.bigq(c(1L,2L))
    lambda <- c(3,2,1)
    expect_identical(SchurR(x, lambda), as.bigq(0L))
    expect_identical(SchurR(x, lambda, algorithm = "naive"), as.bigq(0L))
    # polynomial
    n <- 2
    lambda <- c(3,2,1)
    expect_true(SchurPolR(n, lambda) == as.qspray(0))
    expect_identical(SchurPolR(n, lambda, algorithm = "naive"),
                     as.qspray(0))
    expect_identical(SchurPolR(n, lambda, exact = FALSE, algorithm = "naive"),
                     mvp::constant(0))
    expect_identical(SchurPolR(n, lambda, algorithm = "naive",
                             basis = "MSF"),
                     as.qspray(0))
    expect_identical(SchurPolR(n, lambda, exact = FALSE, algorithm = "naive",
                             basis = "MSF"),
                     mvp::constant(0))
  }
)


test_that(
  "Schur (3,2) - gmp", {
    x <- as.bigq(3L:5L, c(10L,2L,1L))
    expected <- x[1]^3*x[2]^2 + x[1]^3*x[3]^2 + x[1]^3*x[2]*x[3] +
      x[1]^2*x[2]^3 + x[1]^2*x[3]^3 + 2*x[1]^2*x[2]*x[3]^2 +
      2*x[1]^2*x[2]^2*x[3] + x[1]*x[2]*x[3]^3 + 2*x[1]*x[2]^2*x[3]^2 +
      x[1]*x[2]^3*x[3] + x[2]^2*x[3]^3 + x[2]^3*x[3]^2
    naive <- SchurR(x, c(3,2), algorithm = "naive")
    DK <- SchurR(x, c(3,2), algorithm = "DK")
    expect_identical(naive, expected)
    expect_identical(DK, expected)
  }
)

test_that(
  "Schur (3,2) - numeric", {
    x <- c(3L:5L) / c(10L,2L,1L)
    expected <- x[1]^3*x[2]^2 + x[1]^3*x[3]^2 + x[1]^3*x[2]*x[3] +
      x[1]^2*x[2]^3 + x[1]^2*x[3]^3 + 2*x[1]^2*x[2]*x[3]^2 +
      2*x[1]^2*x[2]^2*x[3] + x[1]*x[2]*x[3]^3 + 2*x[1]*x[2]^2*x[3]^2 +
      x[1]*x[2]^3*x[3] + x[2]^2*x[3]^3 + x[2]^3*x[3]^2
    naive <- SchurR(x, c(3,2), algorithm = "naive")
    DK <- SchurR(x, c(3,2), algorithm = "DK")
    expect_equal(naive, expected)
    expect_equal(DK, expected)
  }
)

test_that(
  "SchurPol is correct", {
    lambda <- c(3,2)
    pol <- SchurPolR(4, lambda, algorithm = "naive")
    x <- as.bigq(c(6L,-7L,8L,9L), c(1L,2L,3L,4L))
    polEval <- evalQspray(pol, x)
    expect_identical(polEval, SchurR(as.bigq(x), lambda))
  }
)

test_that(
  "Pieri rule", {
    n <- 3
    P1 <- SchurPolR(n, c(3, 2)) + 2 * SchurPolR(n, c(2, 2, 1)) +
      SchurPolR(n, c(3, 1, 1)) + 2 * SchurPolR(n, c(2, 1, 1, 1)) +
      SchurPolR(n, c(1, 1, 1, 1, 1))
    P2 <- esPolynomial(n, c(2, 2, 1))
    expect_true(P1 == P2)
  }
)

test_that(
  "SchurPolCPP is correct", {
    lambda <- c(3, 2)
    pol <- SchurPol(4, lambda)
    x <- as.bigq(c(6L,-7L,8L,9L), c(1L,2L,3L,4L))
    polEval <- evalQspray(pol, x)
    expect_identical(polEval, SchurR(as.bigq(x), lambda))
  }
)

test_that(
  "SchurCPP is correct", {
    x <- as.bigq(c(6L, -7L, 8L, 9L), c(1L, 2L, 3L, 4L))
    lambda <- c(3, 2)
    res <- Schur(x, lambda)
    expect_identical(res, SchurR(x, lambda))
    #
    x <- c(6, -7, 8, 9) / c(1, 2, 3, 4)
    lambda <- c(3, 2)
    res <- Schur(x, lambda)
    expect_equal(res, SchurR(x, lambda))
  }
)

test_that("Schur polynomial and semistandard Young tableaux", {
  skip_if_not_installed("syt")
  lambda <- c(3, 1)
  ssytx <- syt::all_ssytx(lambda, 4)
  wt <- function(ssyt) {
    ssyt <- unlist(ssyt)
    vapply(1:4, function(k) {
      length(which(ssyt == k))
    }, integer(1L))
  }
  qlones <- lapply(1:4, qlone)
  monomial <- function(ssyt) {
    powers <- wt(ssyt)
    Reduce(`*`, lapply(1:4, function(k) qlones[[k]]^powers[k]))
  }
  monomials <- lapply(ssytx, monomial)
  obtained <- Reduce(`+`, monomials)
  expected <- SchurPolR(4, lambda)
  expect_true(obtained == expected)
})