#devtools::test("asremlPlus")
context("model_selection")

cat("#### Test for chooseModel.data.frame with asreml4\n")
test_that("choose.model.data.frame_asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml)
  library(asremlPlus)
  print(packageVersion("asreml"))
  #'## Load data
  data("Ladybird.dat")

  #'## ANOVA of logits
  Ladybird.aov <- aov(logitP ~ Host*Cadavers*Ladybird + Error(Run/Plant),
                      data=Ladybird.dat)
  summary(Ladybird.aov)

  #'## Mixed model analysis of logits
  m <- asreml(logitP ~ Host*Cadavers*Ladybird,
              random = ~ Run,
              residual = ~ Run:Plant,
              data = Ladybird.dat)
  testthat::expect_true(all(summary(m)$varcomp$bound == c("B", "P"))) #shows bound Run component

  #'### Unconstrain Reps to make the analysis equivalent to ANOVA
  m <- setvarianceterms(m$call, terms = "Run", bounds = "U")
  summary(m)$varcomp #shows negative Run component
  testthat::expect_true(m$vparameters["Run"] < 0)

  #'### Use chooseModel.data.frame
  wald.tab <- wald.asreml(m, denDF = "numeric")$Wald
  testthat::expect_equal(nrow(wald.tab), 8)

  #'### Choose marginality-compliant model from wald.tab, obtaining marginality using pstructure
  Ladybird.pstr <- pstructure(formula = ~ Host*Cadavers*Ladybird,
                              data = Ladybird.dat)
  HCL.marg <- marginality(Ladybird.pstr)
  testthat::expect_equal(nrow(HCL.marg), 7)
  sigmod <- chooseModel(wald.tab, terms.marginality = HCL.marg)
  testthat::expect_true(all(unlist(lapply(sigmod$sig.terms, function(term) term)) ==
                              c("Cadavers:Ladybird", "Host")))
  testthat::expect_equal(nrow(sigmod$choose.summary), 5)
  testthat::expect_true(all(names(sigmod$choose.summary) == c("terms", "DF", "denDF", "p", "action")))

  #'### Rechoose marginality-compliant model from wald.tab, but omit DF and denDF
  sigmod <- chooseModel(wald.tab, omit.DF = TRUE, terms.marginality = HCL.marg)
  testthat::expect_equal(nrow(sigmod$choose.summary), 5)
  testthat::expect_true(all(names(sigmod$choose.summary) == c("terms", "p", "action")))
  sigmod <- chooseModel(wald.tab, denDF = NA, terms.marginality = HCL.marg)
  testthat::expect_equal(nrow(sigmod$choose.summary), 5)
  testthat::expect_true(all(names(sigmod$choose.summary) == c("terms", "DF", "denDF", "p", "action")))

  #'### Specify the denDF argument in various ways, all of which result in the overwriting of denDF
  sigmod <- chooseModel(wald.tab, denDF = wald.tab$denDF, terms.marginality = HCL.marg)
  testthat::expect_equal(nrow(sigmod$choose.summary), 5)
  testthat::expect_true(all(names(sigmod$choose.summary) == c("terms", "DF", "denDF", "p", "action")))

  den.df <- wald.tab$denDF
  sigmod <- chooseModel(wald.tab, denDF = den.df, terms.marginality = HCL.marg)
  testthat::expect_equal(nrow(sigmod$choose.summary), 5)
  testthat::expect_true(all(names(sigmod$choose.summary) == c("terms", "DF", "denDF", "p", "action")))

  sigmod <- chooseModel(wald.tab, denDF = 59, terms.marginality = HCL.marg)
  testthat::expect_equal(nrow(sigmod$choose.summary), 5)
  testthat::expect_true(all(names(sigmod$choose.summary) == c("terms", "DF", "denDF", "p", "action")))

  new.tab <- wald.tab
  names(new.tab)[match("denDF", names(new.tab))] <- "den.df"
  sigmod <- chooseModel(wald.tab, denDF = 59, terms.marginality = HCL.marg)
  testthat::expect_equal(nrow(sigmod$choose.summary), 5)
  testthat::expect_true(all(names(sigmod$choose.summary) == c("terms", "DF", "denDF", "p", "action")))

})

cat("#### Test for chooseModel.asrtests with asreml4\n")
test_that("choose.model.asrtests_asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml)
  library(asremlPlus)
  print(packageVersion("asreml"))
  data(WaterRunoff.dat)
  asreml::asreml.options(keep.order = TRUE)
  current.asr <- do.call("asreml",
                         args = list(fixed = log.Turbidity ~ Benches +
                                       (Sources * (Type + Species)) * Date,
                                     random = ~Benches:MainPlots:SubPlots:spl(xDay),
                                     data = quote(WaterRunoff.dat)))
  current.asrt <- as.asrtests(current.asr, NULL, NULL)

  #some tests for validWaldTab
  testthat::expect_error(test.wald <- as.asrtests(current.asr,
                                                  wald.tab = WaterRunoff.dat))
  asrt.wald <- testranfix(current.asrt, term = "Sources:Species", ssType = "conditional")
  testthat::expect_equal(ncol(asrt.wald$wald.tab), 6)
  testthat::expect_true("F.con" %in% colnames(asrt.wald$wald.tab))

  terms.treat <- c("Sources", "Type", "Species",
                   "Sources:Type", "Sources:Species")
  terms <- sapply(terms.treat,
                  FUN=function(term){paste("Date:",term,sep="")},
                  simplify=TRUE)
  terms <- c("Date", terms)
  terms <- unname(terms)
  marginality <-  matrix(c(1,0,0,0,0,0, 1,1,0,0,0,0,  1,0,1,0,0,0,
                           1,0,1,1,0,0, 1,1,1,0,1,0, 1,1,1,1,1,1), nrow=6)
  rownames(marginality) <- terms
  colnames(marginality) <- terms
  choose <- chooseModel(current.asrt, marginality, denDF="algebraic")
  current.asrt <- choose$asrtests.obj
  sig.terms <- choose$sig.terms
  testthat::expect_equal(length(sig.terms), 2)
  testthat::expect_equal(sig.terms[[1]], "Date:Species")
  testthat::expect_equal(sig.terms[[2]], "Date:Sources")
})

cat("#### Test for testing at terms with asreml4\n")
test_that("at_testing_asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml)
  library(asremlPlus)
  print(packageVersion("asreml"))
  #'## Load data
  data("Exp355.Control.dat")

  dat <- with(dat, dat[order(Genotype, Salt, NP_AMF, InTreat), ])

  #Fit model with quotes around AMF_plus
  # NB must have quotes for character levels,
  # but cannot have in testranfix term because not in wald.tab rownames
  current.asr <- asreml(fixed = TSP ~ Lane + xPosn + AMF*Genotype*NP +
                          at(AMF, "AMF_plus"):per.col + (Genotype*NP):at(AMF, "AMF_plus"):per.col,
                        random = ~ spl(xPosn) + Position ,
                        residual = ~ Genotype:idh(NP_AMF):InTreat,
                        keep.order=TRUE, data = dat,
                        maxiter=50, na.action = na.method(x="include"))

  current.asrt <- as.asrtests(current.asr, NULL, NULL)
  current.asrt <- rmboundary(current.asrt)
  testthat::expect_equal(nrow(current.asrt$wald.tab),14)
  testthat::expect_equal(nrow(summary(current.asrt$asreml.obj)$varcomp),7)

  t.asrt <- testranfix(current.asrt, term = "Genotype:NP:at(AMF, AMF_plus):per.col",
                       drop.fix.ns = TRUE)
  t.asrt$wald.tab
  testthat::expect_equal(nrow(t.asrt$wald.tab), 13)
  #Change position of at term in testranfix
  t.asrt <- testranfix(current.asrt, term = "at(AMF, AMF_plus):per.col:Genotype:NP",
                       drop.fix.ns = TRUE)
  t.asrt$wald.tab
  testthat::expect_equal(nrow(t.asrt$wald.tab), 13)

  #Fit model with level index of 2
  current.asr <- asreml(fixed = TSP ~ Lane + xPosn + AMF*Genotype*NP +
                          at(AMF, "AMF_plus"):per.col + (Genotype*NP):at(AMF, 2):per.col,
                        random = ~ spl(xPosn) + Position ,
                        residual = ~ Genotype:idh(NP_AMF):InTreat,
                        keep.order=TRUE, data = dat,
                        maxiter=50, na.action = na.method(x="include"))

  current.asrt <- as.asrtests(current.asr, NULL, NULL)
  current.asrt <- rmboundary(current.asrt)
  testthat::expect_equal(nrow(current.asrt$wald.tab),14)
  testthat::expect_equal(nrow(summary(current.asrt$asreml.obj)$varcomp),7)

  t.asrt <- testranfix(current.asrt, term = "at(AMF, AMF_plus):per.col:Genotype:NP",
                       drop.fix.ns = TRUE)
  t.asrt$wald.tab
  testthat::expect_equal(nrow(t.asrt$wald.tab), 13)

  #Test for a numeric level that is not the same as the levels index (1:no.levels)
  current.asr <- asreml(fixed = TSP ~ at(Lane, 4) + xPosn + AMF*Genotype*NP +
                          at(AMF, "AMF_plus"):per.col + (Genotype*NP):at(AMF, c(2)):per.col,
                        random = ~ spl(xPosn) + Position ,
                        residual = ~ Genotype:idh(NP_AMF):InTreat,
                        keep.order=TRUE, data = dat,
                        maxiter=50, na.action = na.method(x="include"))
  current.asrt <- as.asrtests(current.asr, NULL, NULL)
  current.asrt <- rmboundary(current.asrt)
  current.asrt$wald.tab
  t.asrt <- testranfix(current.asrt, term = "at(Lane, 8)",
                       drop.fix.ns = TRUE)
  t.asrt$wald.tab
  testthat::expect_equal(nrow(t.asrt$wald.tab), 13)
})

cat("#### Test for testing MET at terms with asreml4\n")
test_that("at_multilevel_asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml)
  library(asremlPlus)
  print(packageVersion("asreml"))

  #'## Load data
  data(MET)
  asreml.options(design = TRUE, keep.order=TRUE)

  #Test at
  asreml.obj <-asreml(fixed = GY.tha ~  + at(expt, c(1:5)):rep + at(expt, c(1)):vrow +
                        at(expt, c(2,3,6,7)):colblocks +
                        at(expt, c(1:5,7)):vcol + Genotype*Condition*expt,
                      random = ~  at(expt, c(1)):dev(vrow) + at(expt, c(2)):spl(vcol) +
                        at(expt, c(3,5,7)):dev(vcol) + at(expt, c(7)):units,
                      data=comb.dat, maxiter = 100, workspace = "1Gb")

  summary(asreml.obj)$varcomp
  current.asrt <- as.asrtests(asreml.obj, NULL, NULL)
  testthat::expect_equal(nrow(current.asrt$wald.tab), 24)

  asreml.options(step.size = 0.0001)

  #Single term in at expresion with the level and drop.fix.ns = TRUE -- works
  t.asrt <- testranfix(current.asrt,
                       term = "at(expt, mtnue10):vrow",
                       drop.fix.ns = TRUE,
                       dDF.na = "residual", update = FALSE)
  testthat::expect_equal(nrow(t.asrt$wald.tab), 23)

  #Multiple fixed terms in an at expresion generates an error
  testthat::expect_error(t.asrt <- testranfix(current.asrt,
                                              term = "at(expt, c(1:5)):rep",
                                              drop.fix.ns = TRUE,
                                              dDF.na = "residual", update = FALSE))

  #Multiple random terms in an at expression  generates an error
  testthat::expect_error(t.asrt <- testranfix(current.asrt,
                                              term = "at(expt, c(3,5,7)):dev(vcol)",
                                              drop.ran.ns = TRUE,
                                              dDF.na = "residual", update = FALSE))

  #Single random term in an at expression - thinks absent
  t.asrt <- testranfix(current.asrt,
                       term = "at(expt, tarlee13):dev(vcol)",
                       drop.ran.ns = TRUE,
                       dDF.na = "residual", update = FALSE)
  testthat::expect_equal(t.asrt$test.summary$action[1], "Absent")

  #Test multiple at term with changeTerms
  t.asrt <- changeTerms(current.asrt, dropFixed = "at(expt, c(1:5)):rep", update = FALSE)
  testthat::expect_equal(nrow(t.asrt$wald.tab), 19)
})

cat("#### Test for at terms in testswapran with asreml4\n")
test_that("at_testswapran_asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml)
  library(asremlPlus)
  print(packageVersion("asreml"))
  #'## Load data
  data(longit.dat)

  asreml.options(fail = "soft", upsd = TRUE, pxem = 1, step.size = 0.1, ai.sing = TRUE)
  current.asr <- do.call(asreml,
                         args=list(fixed = Area ~ Block + Treatments + Treatments:xDAP,
                                   random = ~ Block:Cart + at(Treatments):spl(xDAP, k = 10) + Treatments:DAP +
                                     Block:Cart:spl(xDAP) + Block:Cart:xDAP,
                                   residual = ~ Block:Cart:ar1h(DAP),
                                   keep.order=TRUE, data = longit.dat, maxiter=100))

  #'## Function to deal with bound variances - set to 1e-04
  fixBoundResidualVariances <-function(current.asr)
  {
    repeat
    {
      current.call <- current.asr$call
      vpR <- grepl("Block:Cart:DAP!DAP",
                   names(current.asr$vparameters.con), fixed = TRUE)
      vpR <- current.asr$vparameters.con[vpR]
      (terms <- names(vpR[vpR == 7]))
      if (length(terms) == 0 || length(sum(vpR == 4)) > 5) break
      current.asr <- setvarianceterms(current.call, terms = terms,
                                      bounds = "F", initial.values = 0.0001,
                                      ignore.suffices = FALSE)
    }
    invisible(current.asr)
  }
  current.asr <- fixBoundResidualVariances(current.asr)
  testthat::expect_true(all(table(summary(current.asr)$varcomp$bound) ==  c(2,46,1)))

  #'## Load starting model into an asrtests object
  current.asrt <- as.asrtests(current.asr, NULL, NULL, label = "Selected variance model")
  testthat::expect_true(current.asrt$asreml.obj$converge)

  #'### Test for Treatments:DAP deviations terms
  current.asrt <- testranfix(current.asrt, term = "Treatments:DAP",
                             positive.zero = TRUE)
  testthat::expect_equal(current.asrt$test.summary$action[2], "Dropped")
  testthat::expect_true(all(table(summary(current.asrt$asreml.obj)$varcomp$bound) ==  c(2,45,1)))

  #'### Test for different curvatures in splines
  current.asrt <- testswapran(current.asrt, oldterms = "at(Treatments):spl(xDAP, k = 10)",
                              newterms = "at(AMF):Zn:spl(xDAP, k = 10)",
                              simpler = TRUE,
                              label = "Heterogeneous Treatment splines")
  testthat::expect_true(getTestPvalue(current.asrt, label = "Heterogeneous Treatment splines") < 0.05)
  testthat::expect_true(names(current.asrt$asreml.obj$vparameters[1]) ==
                          "at(Treatments, -,0):spl(xDAP, k = 10)")
  testthat::expect_true(names(current.asrt$asreml.obj$vparameters[5]) ==
                          "at(Treatments, +,0):spl(xDAP, k = 10)")
  testthat::expect_true(all(abs(current.asrt$asreml.obj$vparameters[1:8] -
                                  c(233.152932, 502.667930, 74.955973,
                                    2.540186, 42.003197, 61.206138,
                                    32.367734, 36.902978)) < 1e-02))
})

cat("#### Test for spline testing with asreml4\n")
test_that("spl.asrtests_asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml)
  library(asremlPlus)
  print(packageVersion("asreml"))
  data(WaterRunoff.dat)
  asreml::asreml.options(keep.order = TRUE)
  current.asr <- do.call("asreml",
                         args = list(fixed = log.Turbidity ~ Benches +
                                       (Sources * (Type + Species)) * Date,
                                     random = ~Benches:MainPlots:SubPlots:spl(xDay, k = 6),
                                     data = WaterRunoff.dat))
  current.asrt <- as.asrtests(current.asr, NULL, NULL)

  #Test random splines
  current.asrt <- testranfix(current.asrt, term = "Benches:MainPlots:SubPlots:spl(xDay, k = 6)")
  current.asrt$test.summary

  testthat::expect_equal(nrow(current.asrt$test.summary), 1)
  testthat::expect_true(abs(current.asrt$test.summary$p - 0.08013755) < 1e-06)

  data(Wheat.dat)
  #'## Add cubic trend to Row so that spline is not bound
  Wheat.dat <- within(Wheat.dat,
                      {
                        vRow <- as.numeric(Row)
                        vRow <- vRow - mean(unique(vRow))
                        yield <- yield + 10*vRow + 5 * (vRow^2) + 5 * (vRow^3)
                      })

  #'## Fit model using asreml4
  asreml.obj <- asreml(fixed = yield ~ Rep + vRow + Variety,
                       random = ~spl(vRow, k=6) + units,
                       residual = ~ar1(Row):ar1(Column),
                       data = Wheat.dat, trace = FALSE)
  testthat::expect_true(summary(asreml.obj)$varcomp$bound[1] == "B")
  asreml.obj <- asreml(fixed = yield ~ Rep + vRow + Variety,
                       random = ~spl(vRow) + units,
                       residual = ~ar1(Row):ar1(Column),
                       data = Wheat.dat, trace = FALSE)
  testthat::expect_true(summary(asreml.obj)$varcomp$bound[1] == "B")

})

cat("#### Test for reparamSigDevn.asrtests with asreml4\n")
test_that("reparamSigDevn.asrtests_asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml)
  library(asremlPlus)
  data(WaterRunoff.dat)
  asreml::asreml.options(keep.order = TRUE)
  current.asr <- asreml(fixed = log.Turbidity ~ Benches + Sources + Type + Species +
                          Sources:Type + Sources:Species + Sources:Species:xDay +
                          Sources:Species:Date,
                        data = WaterRunoff.dat)
  current.asrt <- as.asrtests(current.asr, NULL, NULL)

  #Examine terms that describe just the interactions of Date and the treatment factors
  terms.treat <- c("Sources", "Type", "Species", "Sources:Type", "Sources:Species")
  date.terms <- sapply(terms.treat,
                       FUN=function(term){paste("Date:",term,sep="")},
                       simplify=TRUE)
  date.terms <- c("Date", date.terms)
  date.terms <- unname(date.terms)
  treat.marginality <-  matrix(c(1,0,0,0,0,0, 1,1,0,0,0,0,  1,0,1,0,0,0,
                                 1,0,1,1,0,0, 1,1,1,0,1,0, 1,1,1,1,1,1), nrow=6)
  rownames(treat.marginality) <- date.terms
  colnames(treat.marginality) <- date.terms
  choose <- chooseModel(current.asrt, treat.marginality, denDF="algebraic")
  current.asrt <- choose$asrtests.obj
  current.asr <- current.asrt$asreml.obj
  sig.date.terms <- choose$sig.terms

  #Remove all Date terms left in the fixed model
  terms <- "(Date/(Sources * (Type + Species)))"
  current.asrt <- changeTerms(current.asrt, dropFixed = terms)
  #if there are significant date terms, reparameterize to xDays + spl(xDays) + Date
  if (length(sig.date.terms) != 0)
  { #add lin + spl + devn for each to fixed and random models
    trend.date.terms <- sapply(sig.date.terms,
                               FUN=function(term){sub("Date","xDay",term)},
                               simplify=TRUE)
    trend.date.terms <- paste(trend.date.terms,  collapse=" + ")
    current.asrt <- changeTerms(current.asrt, addFixed=trend.date.terms)
    trend.date.terms <- sapply(sig.date.terms,
                               FUN=function(term){sub("Date","spl(xDay)",term)},
                               simplify=TRUE)
    trend.date.terms <- c(trend.date.terms, sig.date.terms)
    trend.date.terms <- paste(trend.date.terms,  collapse=" + ")
    current.asrt <- changeTerms(current.asrt, addRandom = trend.date.terms)
    current.asrt <- rmboundary.asrtests(current.asrt)
  }

  #Now test terms for sig date terms
  spl.terms <- sapply(terms.treat,
                      FUN=function(term){paste("spl(xDay):",term,sep="")},
                      simplify=TRUE)
  spl.terms <- c("spl(xDay)",spl.terms)
  lin.terms <- sapply(terms.treat,
                      FUN=function(term){paste(term,":xDay",sep="")},
                      simplify=TRUE)
  lin.terms <- c("xDay",lin.terms)
  systematic.terms <- c(terms.treat, lin.terms, spl.terms, date.terms)
  systematic.terms <- unname(systematic.terms)
  treat.marginality <-  matrix(c(1,0,0,0,0,0, 1,1,0,0,0,0,  1,0,1,0,0,0,
                                 1,0,1,1,0,0, 1,1,1,1,1,0, 1,1,1,1,1,1), nrow=6)
  systematic.marginality <- kronecker(matrix(c(1,0,0,0, 1,1,0,0,
                                               1,1,1,0, 1,1,1,1), nrow=4),
                                      treat.marginality)
  systematic.marginality <- systematic.marginality[-1, -1]
  rownames(systematic.marginality) <- systematic.terms
  colnames(systematic.marginality) <- systematic.terms
  choose <- chooseModel(current.asrt, systematic.marginality,
                        denDF="algebraic", pos=TRUE)
  current.asrt <- choose$asrtests.obj

  #Check if any deviations are significant and, for those that are, go back to
  #fixed dates
  current.asrt <- reparamSigDevn(current.asrt, choose$sig.terms,
                                 trend.num = "xDay", devn.fac = "Date",
                                 denDF = "algebraic")
  k <- match("Sources:Species:Date",rownames(current.asrt$wald.tab))
  testthat::expect_equal(nrow(current.asrt$wald.tab), 9)
  testthat::expect_equal(nrow(current.asrt$test.summary), 6)
  testthat::expect_true(!is.na(k))
})

cat("#### Test for changeModelOnIC with wheat94 using asreml4\n")
test_that("changeModelOnIC_wheat94_asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml)
  library(asremlPlus)
  ## use asremlPlus to analyse the 1994 wheat example from Gilmour et al. (1995)
  data(wheat94.dat)

  #Start with Maximal model
  fm.max <- asreml(yield ~ lin(Row) + lin(Col) + Rowcode + Colcode,
                   random = ~ Variety + Block + Row + spl(Col) + Col + units,
                   residual = ~ ar1(Col):ar1(Row),
                   data = wheat94.dat)

  current.asrt <- as.asrtests(fm.max, NULL, NULL,
                              label = "Maximal model", IClikelihood = "full")
  current.asrt <- iterate(current.asrt)
  testthat::expect_true(tail(current.asrt$test.summary$action,1) == "Starting model")
  testthat::expect_equal(current.asrt$test.summary$DF, 7)
  testthat::expect_equal(current.asrt$test.summary$denDF, 8)
  testthat::expect_equal(nrow(summary(current.asrt$asreml.obj)$varcomp), 9) #includes bound Block

  current.asrt <- changeModelOnIC(current.asrt, dropRandom = "Block",
                                  IClikelihood = "full", checkboundaryonly = TRUE, which.IC="AIC")

  current.asrt <- rmboundary(current.asrt)
  testthat::expect_equal(nrow(summary(current.asrt$asreml.obj)$varcomp),
                         current.asrt$test.summary$denDF[1])

  #Drop random Row and Col terms
  current.asrt <- changeModelOnIC(current.asrt, dropRandom = "Row + Col",
                                  label = "Drop Row + Col",
                                  which.IC = "AIC", IClikelihood = "full")
  testthat::expect_equal(getTestEntry(current.asrt, label = "Drop Row + Col")[["denDF"]], -2)
  testthat::expect_equal(getTestEntry(current.asrt, label = "Drop Row + Col")[["action"]], "Unswapped")

  #Drop random spl(Col) term
  current.asrt <- changeModelOnIC(current.asrt, dropRandom = "spl(Col)",
                                  label = "Drop spl(Col)", IClikelihood = "full")
  testthat::expect_true(getTestEntry(current.asrt, label = "Drop spl(Col)")[["denDF"]] %in% c(-2,-3))
  testthat::expect_equal(getTestEntry(current.asrt, label = "Drop spl(Col)")[["action"]], "Unswapped")
  testthat::expect_true(abs(getTestEntry(current.asrt, label = "Drop spl(Col)")[["AIC"]] - 6.981351) < 1e-05)

  #Drop random units term
  current.asrt <- changeModelOnIC(current.asrt, dropRandom = "units",
                                  label = "Drop units", IClikelihood = "full")
  testthat::expect_equal(getTestEntry(current.asrt, label = "Drop units")[["denDF"]], -1)
  testthat::expect_equal(getTestEntry(current.asrt, label = "Drop units")[["action"]], "Unswapped")
  testthat::expect_true(abs(getTestEntry(current.asrt, label = "Drop units")[["AIC"]] - 9.511413) < 1e-05)

  mod <- printFormulae(current.asrt$asreml.obj)
  testthat::expect_equal(length(mod), 3)

  #Use REML likelihood and BIC
  current.asrt <- as.asrtests(fm.max, NULL, label = "Maximal model",
                              IClikelihood = "REML")
  current.asrt <- iterate(current.asrt)
  current.asrt <- rmboundary(current.asrt)
  testthat::expect_equal(nrow(current.asrt$test.summary), 2)

  #Drop random Row and Col terms
  current.asrt <- changeModelOnIC(current.asrt, dropRandom = "Row + Col",
                                  label = "Drop Row + Col",
                                  which.IC = "BIC", IClikelihood = "REML")
  testthat::expect_equal(current.asrt$test.summary$denDF[3], -2)
  testthat::expect_equal(current.asrt$test.summary$action[current.asrt$test.summary$terms ==
                                                            "Drop Row + Col"], "Swapped")
  testthat::expect_true((abs(current.asrt$test.summary$BIC[3]) - 8.598262) < 1e-02)

  #Drop random spl(Col) term
  current.asrt <- changeModelOnIC(current.asrt, dropRandom = "spl(Col)",
                                  label = "Drop spl(Col)",
                                  which.IC = "BIC", IClikelihood = "REML")
  testthat::expect_true(current.asrt$test.summary$denDF[4] %in% c(-1, -2))
  testthat::expect_equal(current.asrt$test.summary$action[current.asrt$test.summary$terms ==
                                                            "Drop spl(Col)"], "Swapped")

  #Drop random units term
  current.asrt <- changeModelOnIC(current.asrt, dropRandom = "units",
                                  label = "Drop units",
                                  which.IC = "BIC", IClikelihood = "REML")
  testthat::expect_equal(current.asrt$test.summary$denDF[5], -1)
  testthat::expect_equal(current.asrt$test.summary$action[current.asrt$test.summary$terms ==
                                                            "Drop units"], "Unswapped")

  mod <- printFormulae(current.asrt$asreml.obj)
  testthat::expect_equal(length(mod), 3)

})

cat("#### Test for changeModelOnIC example using asreml4\n")
test_that("changeModelOnIC_Example_asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml)
  library(asremlPlus)
  ## use asremlPlus to analyse the wheat (barley) example from section 8.6 of the asreml manual (Butler et al. 2010)
  data(Wheat.dat)

  #'## Fit maximal model
  current.asr <- asreml(yield ~ Rep + WithinColPairs + Variety,
                        random = ~ Row + Column + units,
                        residual = ~ ar1(Row):ar1(Column),
                        data=Wheat.dat)
  current.asr <- update(current.asr)
  current.asrt <- as.asrtests(current.asr, NULL, NULL,
                              label = "Maximal model", IClikelihood = "full")
  #current.asrt <- rmboundary(current.asrt)
  #testthat::expect_true(current.asrt$asreml.obj$converge)
  testthat::expect_true(current.asrt$test.summary$action[1] == "Starting model")
  testthat::expect_equal(current.asrt$test.summary$DF[1], 31)
  testthat::expect_equal(current.asrt$test.summary$denDF[1], 5)
  testthat::expect_equal(nrow(summary(current.asrt$asreml.obj)$varcomp), 6)

  # Drop both Row and Column
  current.asrt <- changeModelOnIC(current.asrt,
                                  dropRandom = "Row + Column", label = "Drop Row + Column",
                                  checkboundaryonly = TRUE,
                                  which.IC = "AIC", IClikelihood = "full")
  testthat::expect_true(current.asrt$asreml.obj$converge)
  testthat::expect_equal(current.asrt$test.summary$denDF[2], -1)

  # Replace residual with model without Row autocorrelation
  current.asrt <- changeModelOnIC(current.asrt,
                                  newResidual = "Row:ar1(Column)",
                                  label="Row autocorrelation",
                                  IClikelihood = "full")
  testthat::expect_true(current.asrt$asreml.obj$converge)
  testthat::expect_equal(current.asrt$test.summary$denDF[3], -2)
  testthat::expect_true((abs(current.asrt$test.summary$AIC[3]) - 21.709898) < 1e-03)

  mod <- printFormulae(current.asrt$asreml.obj)
  testthat::expect_equal(length(mod), 3)
  testthat::expect_true(grepl("units", mod[2], fixed = TRUE))

})

cat("#### Test for fixedcorrelations using asreml4\n")
test_that("Fixedcorrelations_asreml4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(asreml)
  library(asremlPlus)
  ## use asremlPlus to analyse the wheat (barley) example from section 8.6 of the asreml manual (Butler et al. 2010)
  data(PSA.27.dat)

  asreml.options(ai.sing = TRUE)
  m.asr <- do.call(asreml,
                   args=list(fixed = PSA.27 ~ Lane + Position,
                             residual = ~ ar1(Lane):Position,
                             data = PSA.27.dat, maxiter=50))
  m.asrt <- as.asrtests(m.asr, NULL, NULL, label = "Start with Lane autocorrelation",
                        IClikelihood = "full")
  m.asrt <- rmboundary(m.asrt)
  testthat::expect_true(m.asrt$asreml.obj$converge)

  testthat::expect_warning(
    m1.asrt <- changeModelOnIC(m.asrt, addRandom = "units", label = "units", allow.fixedcorrelation = FALSE,
                               IClikelihood = "full"))
  tests<- m1.asrt$test.summary
  testthat::expect_equal(m1.asrt$test.summary$action[2], "Unchanged - fixed correlation")
  testthat::expect_true(is.null(getFormulae(m1.asrt$asreml.obj)$random))

  m2.asrt <- changeModelOnIC(m.asrt, addRandom = "units", label = "units", allow.fixedcorrelation = TRUE,
                             IClikelihood = "full")
  testthat::expect_equal(m2.asrt$test.summary$action[2], "Swapped")
  testthat::expect_true(grepl("units", as.character(getFormulae(m2.asrt$asreml.obj)$random)[2], fixed = TRUE))
  summary(m2.asrt$asreml.obj)$varcomp
  testthat::expect_equal(unname(vpc.char(m2.asrt$asreml.obj)["Lane:Position!Lane!cor"]), "F")

  m3.asrt <- changeTerms(m.asrt, addRandom = "units", label = "Add units", allow.fixedcorrelation = FALSE)
  testthat::expect_equal(m3.asrt$test.summary$action[2], "Unchanged - fixed correlation")
  testthat::expect_true(is.null(getFormulae(m3.asrt$asreml.obj)$random))

  m4.asrt <- changeTerms(m.asrt, addRandom = "units", label = "Add units", allow.fixedcorrelation = TRUE)
  testthat::expect_equal(m4.asrt$test.summary$action[2], "Changed random")
  testthat::expect_true(grepl("units", as.character(getFormulae(m4.asrt$asreml.obj)$random)[2], fixed = TRUE))

  m4.asrt <- testranfix(m4.asrt, term = "units", positive.zero = TRUE, allow.fixedcorrelation = TRUE)
  testthat::expect_equal(m4.asrt$test.summary$action[3], "Retained")
  testthat::expect_true(grepl("units", as.character(getFormulae(m4.asrt$asreml.obj)$random)[2], fixed = TRUE))
  testthat::expect_equal(unname(vpc.char(m4.asrt$asreml.obj)["Lane:Position!Lane!cor"]), "F")

  m5.asrt <- testranfix(m4.asrt, term = "units", positive.zero = TRUE, allow.fixedcorrelation = TRUE,
                        IClikelihood = "REML")
  testthat::expect_equal(m5.asrt$test.summary$action[4], "Retained")
  testthat::expect_true(grepl("units", as.character(getFormulae(m5.asrt$asreml.obj)$random)[2], fixed = TRUE))
  testthat::expect_equal(unname(vpc.char(m5.asrt$asreml.obj)["Lane:Position!Lane!cor"]), "F")
  testthat::expect_true(all(abs(c(m5.asrt$test.summary$AIC[4],m5.asrt$test.summary$BIC[4]) -
                                  c(2352.823, 2361.365)) < 1e-04))

  m6.asrt <- testranfix(m4.asrt, term = "Lane", allow.fixedcorrelation = TRUE,
                        IClikelihood = "REML")
  testthat::expect_equal(m6.asrt$test.summary$action[4], "Significant")

  testthat::expect_warning(
    m6.asrt <- testranfix(m4.asrt, term = "Lane", allow.fixedcorrelation = FALSE,
                          IClikelihood = "REML"),
    regexp = "The estimated value of one or more correlations in the supplied asreml fit for PSA.27 is fixed")
  testthat::expect_equal(m6.asrt$test.summary$action[4], "Significant")

  #The fixed correlation is in m4.asrt and do not know how to remove it.
  testthat::expect_warning(
    m6.asrt <- testranfix(m4.asrt, term = "units", positive.zero = TRUE, allow.fixedcorrelation = FALSE),
    regexp = "The estimated value of one or more correlations in the supplied asreml fit for PSA.27 is fixed")
  testthat::expect_equal(m6.asrt$test.summary$action[4], "Unchanged - fixed correlation")
  testthat::expect_true(grepl("units", as.character(getFormulae(m6.asrt$asreml.obj)$random)[2], fixed = TRUE))

  #Start with both Lane and Position autocorrelation
  m.asr <- do.call(asreml,
                   args=list(fixed = PSA.27 ~ Lane + Position,
                             random = ~ units,
                             residual = ~ ar1(Lane):ar1(Position),
                             data = PSA.27.dat, maxiter=75))
  m.asrt <- as.asrtests(m.asr, NULL, NULL, label = "Start with all autocorrelation",
                        IClikelihood = "full")
  m.asrt <- rmboundary(m.asrt)
  testthat::expect_true(m.asrt$asreml.obj$converge)

  m1.asrt <- changeModelOnIC(m.asrt, newResidual = "ar1(Lane):Position", label = "Lane autocorrelation",
                             allow.fixedcorrelation = FALSE,
                             IClikelihood = "full")
  testthat::expect_equal(m1.asrt$test.summary$action[2], "Unchanged - fixed correlation")
  testthat::expect_true(grepl("ar1(Lane):ar1(Position)",
                              as.character(getFormulae(m1.asrt$asreml.obj)$residual)[2], fixed = TRUE))

  m2.asrt <- changeModelOnIC(m.asrt, newResidual = "ar1(Lane):Position", label = "Lane autocorrelation",
                             allow.fixedcorrelation = TRUE,
                             IClikelihood = "full")
  testthat::expect_equal(m2.asrt$test.summary$action[2], "Swapped")
  testthat::expect_true(grepl("ar1(Lane):Position",
                              as.character(getFormulae(m2.asrt$asreml.obj)$residual)[2], fixed = TRUE))

  m3.asrt <- testresidual(m.asrt, terms = "ar1(Lane):Position", label = "Lane autocorrelation",
                          simpler = TRUE, allow.fixedcorrelation = FALSE)
  testthat::expect_equal(m3.asrt$test.summary$action[2], "Unchanged - fixed correlation")
  testthat::expect_true(grepl("ar1(Lane):ar1(Position)",
                              as.character(getFormulae(m1.asrt$asreml.obj)$residual)[2], fixed = TRUE))

  m4.asrt <- testresidual(m.asrt, terms = "ar1(Lane):Position", label = "Lane autocorrelation",
                          simpler = TRUE, allow.fixedcorrelation = TRUE)
  testthat::expect_equal(m4.asrt$test.summary$action[2], "Swapped")
  testthat::expect_true(grepl("ar1(Lane):Position",
                              as.character(getFormulae(m2.asrt$asreml.obj)$residual)[2], fixed = TRUE))

  #Check warning message when supplied asreml.obj has a fixed correlation
  testthat::expect_output(testthat::expect_warning(
    m.asr <- do.call(asreml,
                     args=list(fixed = PSA.27 ~ 1,
                               random = ~ Lane + Position + units,
                               residual = ~ ar1(Lane):Position,
                               data = PSA.27.dat, maxiter=50))))
  testthat::expect_warning(
    m.asrt <- as.asrtests(m.asr, NULL, NULL, label = "Start with all autocorrelation",
                          IClikelihood = "full"))
  m.asrt <- rmboundary(m.asrt)
  testthat::expect_false(m.asrt$asreml.obj$converge)

  testthat::expect_warning(
    m1.asrt <- changeModelOnIC(m.asrt, dropRandom = "units", allow.fixedcorrelation = FALSE),
    regexp = "The estimated value of one or more correlations in the supplied asreml fit for PSA.27 is fixed")
  testthat::expect_warning(
    m2.asrt <- testresidual(m.asrt, terms = "ar1(Lane):ar1(Position)", allow.fixedcorrelation = FALSE),
    regexp = "The estimated value of one or more correlations in the supplied asreml fit for PSA.27 is fixed")
  m1.asr <- newfit(m.asr, random. = ~ . - units, allow.fixedcorrelation = TRUE)
  testthat::expect_false(any("units" == rownames(attr(m1.asr$formulae$random, which = "factors"))))

  testthat::expect_warning(
    m2.asr <- newfit(m.asr, random. = ~ . - units, allow.fixedcorrelation = FALSE),
    regexp = "The estimated value of one or more correlations in the supplied asreml fit for PSA.27 is fixed")
  testthat::expect_true(any("units" == rownames(attr(m2.asr$formulae$random, which = "factors"))))

  #Test repararmSigDevn
  PSA.27.dat <- within(PSA.27.dat,
                       {
                         xPosn <- dae::as.numfac(Position)
                         xPosn <- xPosn - mean(unique(xPosn))
                       })
  m.asr <- do.call(asreml,
                   args=list(fixed = PSA.27 ~ Lane  + xPosn,
                             random = ~ spl(xPosn) + Position + units,
                             residual = ~ ar1(Lane):Position,
                             data = PSA.27.dat, maxiter=75))
  m.asrt <- as.asrtests(m.asr, NULL, NULL, label = "Start with all autocorrelation",
                        IClikelihood = "full")
  asreml.options(ai.sing = TRUE)
  m1.asrt <- reparamSigDevn(m.asrt, terms = "Position", trend.num = "xPosn", devn.fac = "Position",
                            allow.fixedcorrelation = TRUE)
  testthat::expect_equal(m1.asrt$test.summary$action[2], "Changed fixed, random")
  testthat::expect_equal(unname(vpc.char(m1.asrt$asreml.obj)["Lane:Position!Lane!cor"]), "B")

  m2.asrt <- reparamSigDevn(m.asrt, terms = "Position", trend.num = "xPosn", devn.fac = "Position",
                            allow.fixedcorrelation = FALSE)
  testthat::expect_equal(m2.asrt$test.summary$action[2], "Unchanged - fixed correlation")

  #Test testswapran
  m.asr <- do.call(asreml,
                   args=list(fixed = PSA.27 ~ 1,
                             random = ~ Lane + units,
                             residual = ~ ar1(Lane):Position,
                             data = PSA.27.dat, maxiter=100))
  m.asrt <- as.asrtests(m.asr, NULL, NULL, label = "Start with all autocorrelation",
                        IClikelihood = "full")
  m.asrt <- rmboundary(m.asrt)
  testthat::expect_true(m.asrt$asreml.obj$converge)

  m1.asrt <- testswapran(m.asrt, oldterms = "Lane", newterms = "Position", allow.fixedcorrelation = TRUE)
  testthat::expect_equal(m1.asrt$test.summary$action[2], "Rejected")
  testthat::expect_equal(unname(vpc.char(m1.asrt$asreml.obj)["Lane:Position!Lane!cor"]), "F")

  testthat::expect_warning(
    m2.asrt <- testswapran(m.asrt, oldterms = "Lane", newterms = "Position", allow.fixedcorrelation = FALSE),
    regexp = "The estimated value of one or more correlations in the supplied asreml fit for PSA.27 is fixed")

})


deck <- read.csv('https://github.com/gumdropsteve/datasets/raw/master/deck.csv')

set.seed(42)  # so we get the same 'random' shuffle every time (don't do this IRL unless you have a reason to)

rows <- sample(nrow(deck))

shuffled_deck <- deck[rows, ]

shuffled_deck


HELP
articles <- read.csv(url("https://raw.githubusercontent.com/go95/big_data_intro/master/Abdulkadiroglou.csv"))

hirsch_index <- function(articles) {

  citations <- articles [["Citations"]]
  citations [is.na(citations)] <- 0
  sort(citations, decreasing = TRUE)
  art_number <- length(citations)

  for (x in 1:art_number) {
    if (citations[x] > x) {
      x <- x + 1
    } else break
  }
  if (citations[x] < x) {
    x <- x - 1
  }

  return(x)
}
print(hirsch_index(articles))


df1 <- read_csv("c20210406.csv")
df_1 <- read_csv("c20210406.csv")
spec(df1)

ls(df1)

df1$Agency <- as.factor(df1$Agency)
df1$Call_Disposition <- as.factor(df1$Call_Disposition)
df1$Master_Incident_Number <- as.factor(df1$Master_Incident_Number)
df1$Month <- as.factor(df1$Month)
df1$DOW <- as.factor(df1$DOW)
df1$Shift <- as.factor(df1$Shift)
df1$Problem <- as.factor(df1$Problem)
df1$Call_Received <- as.factor(df1$Call_Received)
df1$CallTaking_Performed_By <- as.factor(df1$CallTaking_Performed_By)
df1$Dispatcher <- as.factor(df1$Dispatcher)

summary(df1)

df1 %>% drop_na()

df1$QueueTime <- as.numeric(df1$Fixed_Time_CallEnteredQueue - df1$`Phone_Pick_Up`)
df1$DispatchTime <-as.numeric(df1$Time_First_Unit_Assigned - df1$Fixed_Time_CallEnteredQueue)
df1$ProcessTime <- as.numeric(df1$`End_Call_Taking` - df1$`Phone_Pick_Up`)

sum(df1$QueueTime < 0, na.rm=TRUE)
sum(df1$DispatchTime < 0, na.rm = TRUE)
sum(df1$ProcessTime < 0, na.rm=TRUE)
sum(df1$QueueTime < 0 & df1$DispatchTime < 0, na.rm=TRUE)
sum(df1$QueueTime < 0 & df1$ProcessTime < 0, na.rm=TRUE)
sum(df1$ProcessTime < 0 & df1$DispatchTime < 0, na.rm=TRUE)

df1 = df1[!df1$QueueTime<0, ]
df1 = df1[!df1$DispatchTime<0, ]
df1 = df1[!df1$ProcessTime<0, ]

create_report(df1)

summary(df1$DOW)

hist(df1$QueueTime)
hist(df1$DispatchTime)
hist(df1$ProcessTime)

describe(df1$QueueTime)
describe(df1$DispatchTime)
describe(df1$ProcessTime)

barplot(table(df1$DOW), horiz = TRUE, lab)
barplot(table(df1$Shift))

# normality tests
# Density Plots
ggdensity(df1$QueueTime, fill = "lightblue")
ggdensity(df1$DispatchTime, fill = "lightblue")
ggdensity(df1$ProcessTime, fill = "lightblue")

# QQ Plots
ggqqplot(df1$QueueTime)
ggqqplot(df1$DispatchTime)
ggqqplot(df1$ProcessTime)

# Shapiro Wilk normality test p < 0.05 = non-normal distribution
shapiro.test(df1$QueueTime)
shapiro.test(df1$DispatchTime)
shapiro.test(df1$ProcessTime)

describeBy(QueueTime + DispatchTime + ProcessTime ~ Agency, data = df1)
describeBy(QueueTime + DispatchTime + ProcessTime ~ DOW, data = df1)
describeBy(QueueTime + DispatchTime + ProcessTime ~ Hour, data = df1)
describeBy(QueueTime + DispatchTime + ProcessTime ~ Shift, data = df1)
describeBy(QueueTime + DispatchTime + ProcessTime ~ DOW + Hour, data = df1)
describeBy(QueueTime + DispatchTime + ProcessTime ~ DOW + Shift, data = df1)

group_by(df1, DOW) %>% summarise(count = n(), median(QueueTime, na.rm = TRUE), median(DispatchTime, na.rm = TRUE), median(ProcessTime, na.rm = TRUE))
group_by(df1, Problem) %>% summarise(count = n(), median(QueueTime, na.rm = TRUE), median(DispatchTime, na.rm = TRUE), median(ProcessTime, na.rm = TRUE))
Problem_stats <- group_by(df1, Problem) %>% summarise(count = n(), median(QueueTime, na.rm = TRUE), median(DispatchTime, na.rm = TRUE), median(ProcessTime, na.rm = TRUE))
group_by(df1, CallTaking_Performed_By) %>% summarise(count = n(), median(QueueTime, na.rm = TRUE), median(DispatchTime, na.rm = TRUE), median(ProcessTime, na.rm = TRUE))
CT_Stats <- group_by(df1, CallTaking_Performed_By) %>% summarise(count = n(), median(QueueTime, na.rm = TRUE), IQR(QueueTime, na.rm = TRUE))
Disp_Stats <- group_by(df1, Dispatcher) %>% summarise(count = n(), median(DispatchTime, na.rm = TRUE), IQR(DispatchTime, na.rm = TRUE))

kruskal.test(QueueTime ~ DOW, data = df1)
kruskal.test(QueueTime ~ CallTaking_Performed_By, data = df1)
kruskal_effsize(QueueTime ~ CallTaking_Performed_By, data = df1)
pairwise.wilcox.test(df1$QueueTime, df1$CallTaking_Performed_By, p.adjust.method = "BH")
dunn_ct <- dunn_test(df1, QueueTime ~ CallTaking_Performed_By, p.adjust.method = "bonferroni")

kruskal.test(QueueTime ~ Shift, data = df1)
kruskal_effsize(QueueTime ~ Shift, data = df1)
pairwise.wilcox.test(df1$QueueTime, df1$Shift, p.adjust.method = "BH")
dunn_shift <- dunn_test(df1, QueueTime ~ Shift, p.adjust.method = "bonferroni")


### fimd9.R
### R code from Van Buuren, S. (2012).
###		Flexible Imputation of Missing Data.
###		CRC/Chapman & Hall, Boca Raton, FL.
### (c) 2012 Stef van Buuren, www.multiple-imputation.com
### Version 1, 21mar2012
### Version 2, 4nov2015 tested with mice 2.23
### Tested with Mac OS X 10.7.3, R2.14-2, mice 2.12

if (packageVersion("mice")<'2.12') stop("This code requires mice 2.12.")

### Section 9.2 SE Fireworks Disaster Study

### Section 9.2.1 Intention to treat

library("mice")
library("lattice")

### Table 9.1

yvars <- c("yc1","yc2","yc3", "yp1","yp2","yp3")
x <- cbind(fdd[,c("id","trt","pp",yvars)])
x

md.pattern(fdd[fdd$pp=="Y",yvars])
md.pattern(fdd[fdd$pp=="N",yvars])

### Section 9.2.2 Imputation model

pred <- fdd.pred
vars <-c("ypa1", "ypb1", "ypc1",
         "ypa2", "ypb2", "ypc2",
         "ypa3", "ypb3", "ypc3")
pred[vars[1:3],vars]

dry <- mice(fdd, maxit=0)
method <- dry$method
method["yc1"] <- "~I(yca1 + ycb1 + ycc1)"
method["yc2"] <- "~I(yca2 + ycb2 + ycc2)"
method["yc3"] <- "~I(yca3 + ycb3 + ycc3)"
method["yp1"] <- "~I(ypa1 + ypb1 + ypc1)"
method["yp2"] <- "~I(ypa2 + ypb2 + ypc2)"
method["yp3"] <- "~I(ypa3 + ypb3 + ypc3)"
imp <- mice(fdd,pred=pred,meth=method,maxit=20,seed=54434)

### Section 9.2.3 Inspecting imputations

lowi <- complete(imp, "long", inc=TRUE)
lowi <- data.frame(lowi,cbcl2=NA, cbin2=NA,cbex2=NA)
lolo <- reshape(lowi, idvar = 'id',
                varying = 11:ncol(lowi),
                direction = "long",
                new.row.names = 1:(nrow(lowi)*3),
                sep="")
lolo <- lolo[order(lolo$.imp, lolo$id, lolo$time),]
row.names(lolo) <- 1:nrow(lolo)

### Figure 9.1

iv <- is.na(lolo[lolo$.imp==0,]$yp)
ivn <- ifelse(iv,1,0)
col12  <- c("grey80","grey80",
            mdc(2),mdc(1),
            mdc(2),"transparent",
            mdc(2),"transparent",
            mdc(2),"transparent",
            mdc(2),"transparent")
ic <- unique(lolo$id[iv])
ss <- lolo$id %in% ic
grp <- 2*as.integer(lolo$.imp) - ivn
loloss <- data.frame(lolo, grp=grp)
trellis.par.set(strip.background=list(col="grey95"))
tp1 <- xyplot(yp~time|factor(id), data=loloss, type="l",
      groups=factor(.imp), col="grey80", subset=ss,
       ylab="UCLA-RI Parent Score", pch=19, cex=1,
       xlab="Time", xlim=c("T1","T2","T3"),
             as.table=TRUE)
tp2 <- xyplot(yp~time|factor(id), data=loloss, type="p",
       groups=grp, col=col12, subset=ss,
       ylab="UCLA-RI Parent Score",
       pch=19,
       cex=0.8,
       xlab="Time", xlim=c("T1","T2","T3"),
       as.table=TRUE)
print(tp1)
print(tp2, newpage=FALSE)

### Figure 9.2

means <- aggregate(lolo$yp, list(lolo$.imp!=0,lolo$trt,lolo$time), mean, na.rm=TRUE)
names(means) <- c(".imp","trt","time","yp")
levels(means$trt) <- c("EMDR","CBT")
tp <- xyplot(yp~time|trt, data=means, type="o", pch=19,
      groups=factor(.imp), col=c(mdc(4), mdc(6)),
       ylab="UCLA-RI Parent Score", lwd=2,
       xlab="Time", xlim=c("T1","T2","T3"))
print(tp)

### Figure 9.3

means <- aggregate(lolo$yc, list(lolo$.imp!=0,lolo$trt,lolo$time), mean, na.rm=TRUE)
names(means) <- c(".imp","trt","time","yc")
levels(means$trt) <- c("EMDR","CBT")
tp <- xyplot(yc~time|trt, data=means, type="o", pch=19,
      groups=factor(.imp), col=c(mdc(4),mdc(6)),
       ylab="UCLA-RI Child Score", lwd=2,
       xlab="Time", xlim=c("T1","T2","T3"))
print(tp)

### Section 9.3 Time raster imputation

library("mice")
library("splines")
library("lme4")

data <- tbc
md.pattern(data)

### remove those with nocc 1 or 2 or 3
data <- data[data$nocc>=3,]

### Section 9.3.3 Broken stick model

### specify break ages
brk <- c(0, 8/365, 1/3, 1, 2, 6, 10, 18, 29)
k <- length(brk)

### calculate B-spline
X <- bs(data$age,
        knots = brk,
        B = c(brk[1],brk[k]+0.0001),
        degree = 1)
X <- X[,-(k+1)]
dimnames(X)[[2]] <- paste("x",1:ncol(X),sep="")
data <- cbind(data,X)
round(head(X,3),2)

### fit broken stick model
fit <- lmer(wgt.z~0+x1+x2+x3+x4+x5+x6+x7+x8+x9+
                 (0+x1+x2+x3+x4+x5+x6+x7+x8+x9|id),
                 data=data)

### calculate size and increment per person
tsiz <- t(ranef(fit)$id) + fixef(fit)
tinc <- diff(tsiz)

### inspect size and increment estimates
round(head(t(tsiz)),2)
round(head(t(tinc)),2)

### broken stick for hgt and BMI
fit.wgt <- fit
fit.hgt <- lmer(hgt.z~0+x1+x2+x3+x4+x5+x6+x7+x8+x9+
                 (0+x1+x2+x3+x4+x5+x6+x7+x8+x9|id),
                 data=data)
fit.bmi <- lmer(bmi.z~0+x1+x2+x3+x4+x5+x6+x7+x8+x9+
                 (0+x1+x2+x3+x4+x5+x6+x7+x8+x9|id),
                 data=data)

### define time warp

warp.setup <- data.frame(age = brk, age2 = seq(0, 29, length.out=k))
warp.model <- lm(age2 ~ bs(age, knots=brk[c(-1,-k)], degree=1) - 1,
                 data=warp.setup, x=T, y=T)
warped.knots <- warp.model$y
maxage <- max(warped.knots)
age2  <- predict(warp.model,newdata=data)
data  <- cbind(data, age2=age2)
rm(age2)

### Figure: time warping function (not in book)

par(fin=c(3,3),omi=c(0,0,0,0),mai=c(1,1,1,1),mfrow=c(1,1),lwd=0.5)
eqscplot(x=brk, y=warp.model$y,
         ylab="Warped age",
         xlab="Age (years)",
         axes=F,type="o",lwd=1,pch=16)
axis(1, at=seq(0,32,4), cex=0.5, pos=c(-0.5,0))
axis(2, at=warp.setup$age2,
     labels=c("0y","8d","4m","1y","2y","6y","10y","18y","29y"),
     line=0.5,cex=0.5)
lines(x=c(0,29), y=c(0,29), lwd=1)

# Prepare for figure 9.5 (weight, height and BMI profiles for six cases)

wsiz.bs <- extractBS(fit.wgt)
hsiz.bs <- extractBS(fit.hgt)
bsiz.bs <- extractBS(fit.bmi)
id <- unique(fit.wgt@flist$id)

data2 <- appendbreak(data, brk, id=id, warp.model=warp.model, typ="pred")
data2[data2$typ=="pred",c("wgt.z","hgt.z","bmi.z")] <- round(cbind(wsiz.bs, hsiz.bs, bsiz.bs),3)

six <- c(1259,7019,2447,7460,8046,7646)
set.seed(23221)
sample <- unique(c(six,sample(unique(tbc$id),300)))

idx <- data2$id %in% six
pd  <- data2[idx,]
pd$id <- as.factor(pd$id)
pd <- cbind(pd,rowname=row.names(pd))
pdr <- reshape(pd,
               varying = c("wgt.z","hgt.z","bmi.z"),
               idvar = "rowname",
               direction="long",
               v.names="y")
pdr$grp <- pdr$time
pdr$grp[pdr$typ=="pred"] <- pdr$grp[pdr$typ=="pred"] + 3

### Figure 9.5 Only weight

tbcstick <- xyplot(y~age2|id, data=pdr, xlim=c(-1,maxage+1), ylim=c(-4,4),
       as.table = TRUE,
       scales = list(x=list(at=warped.knots,
              labels=c("0","8d","4m","1y","2y","6y","10y","18y","29y"))),
                   xlab = "Age", ylab = "Weight SDS",
                   layout = c(2,3),
                   subset = (grp==1 | grp==4),
                   groups = grp,
                   pch=19,
                   type=c(rep("p",3),rep("l",3)),
                   distribute.type = TRUE,
                   lwd=2,
                   col=c(rep(mdc(1),3),rep(mdc(5),3)),
                   panel = function(...) {
         panel.abline(v=warped.knots, lty=2, col="grey80")
         panel.abline(h=c(-2,0,2), lty=1, col="grey80")
         panel.xyplot(...)
       },
       strip = strip.custom(bg="grey95"))
print(tbcstick)

### Same plot, but then with height and BMI added (not in book)

tbcstick <- xyplot(y~age2|id, data=pdr, xlim=c(-1,maxage+1), ylim=c(-4,4),
       as.table = TRUE,
       scales = list(x=list(at=warped.knots,
              labels=c("0","8d","4m","1y","2y","6y","10y","18y","29y"))),
       xlab = "Age", ylab = "Standard Deviation Score (SDS)",
       layout = c(2,3),
       groups = grp,
       pch=20,
       type=c(rep("p",3),rep("l",3)), distribute.type = TRUE,
       lwd=1.5,
       col=c(mdc(1), hcl(80,100,40,0.7),hcl(160,100,40,0.7)),
       panel = function(...) {
         panel.abline(v=warped.knots, lty=2, col="grey80")
         panel.abline(h=c(-2,0,2), lty=1, col="grey80")
         panel.xyplot(...)
       },
       strip = strip.custom(bg="grey95"),
       key = list(
         text   = list(c("Weight","Height","BMI"), cex=0.8),
         lines  = list(lty=1, lwd=2, type="l"),
         col  = c(mdc(1), hcl(80,100,40,0.7),hcl(160,100,40,0.7)),
         columns = 3,
         space  = "bottom",
         border = FALSE)
       )
print(tbcstick)

### Section 9.3.6 Imputation

### append break ages before imputation
id <- unique(data$id)
data2 <- appendbreak(data, brk, id=id, warp.model=warp.model, typ="sup")
table(data2$typ)

options(digits=2)
head(data2)

### specify imputation methods
Y <- c("hgt.z","wgt.z","bmi.z")
imp <- mice(data2, maxit=0)
meth <- imp$method
meth[1:length(meth)] <- ""
meth[Y] <- "2l.norm"

## Note: The following statements are outdated
##       and replaced by the intercept=FALSE option
##       in the call to mice()
## mice.impute.2l.norm.noint <- mice.impute.2l.norm
## meth[Y] <- "2l.norm.noint"

### specify predictor matrix
pred <- imp$pred
pred[1:nrow(pred),1:ncol(pred)] <- 0
pred[Y,"id"] <- (-2) # class variable
pred[Y,"sex"] <- 1 # fixed effect
pred[Y, paste("x",1:9,sep="")] <- 2
pred[Y[1],Y[2]] <- 2  # mutual random effect
pred[Y[2],Y[1]] <- 2  # mutual random effect
pred[Y[3],Y[1:2]] <- 2  # random effect

### specify visit sequence
vis <- 1:3
names(vis) <- c("hgt.z","wgt.z","bmi.z")

### ready to go - TIME CONSUMING (30 MINUTES)
imp.1 <- mice(data2, intercept = FALSE, meth=meth, pred=pred, m=5, maxit=10, seed=52711)
imp.2 <- mice(data2, intercept = FALSE, meth=meth, pred=pred, m=5, maxit=10, seed=88348)
imp.1745 <- ibind(imp.1, imp.2)  ## create m=10 imputations

### Figure 9.6 diagnostic plot
### Note: The solution is different from that in the book
###       The sample size in the book is much larger (n=2604 instead of n=306)
###       The larger sample regularizes many of the imputed sticks
###       The plot for non-typical subject 7646 reveals that
###       with n=306, fit to the data is low for this subject

cd <- complete(imp.1745,"long")
sup <- cd[cd$typ=="sup",]
data3 <- data.frame(.imp=0, data2)
data3 <- rbind(data3, sup[,-2])
idx <- data3$id %in% six
pd  <- data3[idx,]
pd$id <- as.factor(pd$id)
pd$grp <- pd$.imp
pd$grp[pd$grp==0] <- NA
pd$grp[pd$typ=="obs"] <- 11
pd$grp <- reorder(pd$grp, as.numeric(pd$grp))
tbcimp <- xyplot(wgt.z~age2|id, data=pd, xlim=c(-1,maxage+1), ylim=c(-4,4),
       as.table = TRUE,
       scales = list(x=list(at=warped.knots,
              labels=c("0","8d","4m","1y","2y","6y","10y","18y","29y"))),
       xlab = "Age", ylab = "Weight SDS",
       groups=grp, layout = c(2,3),
       pch=c(rep(20,10), 19),
       type=c(rep("l",10),"p"), lwd=c(rep(1,10),1),
       col=c(rep(mdc(5),10),mdc(1)), distribute.type=TRUE,
       panel = function(...) {
         panel.abline(v=warped.knots, lty=2, col="grey80")
         panel.abline(h=c(-2,0,2), lty=1, col="grey80")
         panel.xyplot(...)
       },
       strip=strip.custom(bg="grey95")
       )
print(tbcimp)

### Figure 9.7

cd <- complete(imp.1745,1)
idx <- (cd$id) %in% sample
cd <- cd[idx,]
shingle <- cut(cd$age,breaks=c(brk,29.01),right=FALSE, inc=TRUE,
               labels=c("0d-8d","8d-4m","4m-1y","1y-2y","2y-6y",
                 "6y-10y","10y-18y","18y-29y","29y"))
tbchw <- xyplot(wgt.z~hgt.z|shingle,data=cd,
       xlim=c(-4,4), ylim=c(-4,4), type=c("p","g"),
       group=(typ=="sup"),pch=c(1,20),
       col=c(mdc(1:2)),
       xlab="Height SDS", ylab="Weight SDS",pty="s",
       strip=strip.custom(bg="grey95"))
print(tbchw)

### Section 9.3.7 Complete data analysis

### post-processing of imputed data

imp <- imp.1745
cd <- complete(imp,"long")
sup <- cd[cd$typ=="sup",]

sup$age <- round(sup$age,2)
sup$hgt.z <- round(sup$hgt.z,2)
sup$wgt.z <- round(sup$wgt.z,2)
sup$bmi.z <- round(sup$bmi.z,2)

lowi <- reshape(sup, idvar=c('id','.imp'), timevar = 'age',
                v.names=c('hgt.z','wgt.z','bmi.z'),
                direction="wide",
                drop=c(".id","occ","first","typ","hgt","wgt","bmi",
                  paste("x",1:9,sep=""),"age2"))
hsiz <- lowi[,c(".imp","id","nocc","sex",
                "hgt.z.0","hgt.z.0.02","hgt.z.0.33",
                "hgt.z.1","hgt.z.2","hgt.z.6","hgt.z.10","hgt.z.18",
                "hgt.z.29")]
wsiz <- lowi[,c(".imp","id","nocc","sex",
                "wgt.z.0","wgt.z.0.02","wgt.z.0.33",
                "wgt.z.1","wgt.z.2","wgt.z.6","wgt.z.10","wgt.z.18",
                "wgt.z.29")]
bsiz <- lowi[,c(".imp","id","nocc","sex",
                "bmi.z.0","bmi.z.0.02","bmi.z.0.33",
                "bmi.z.1","bmi.z.2","bmi.z.6","bmi.z.10","bmi.z.18",
                "bmi.z.29")]
# merge outcome data
bsiz <- merge(bsiz, tbc.target,all.x=TRUE)

hinc <- cbind(hsiz[,1:4],t(diff(t(hsiz[,-1:-4]))))
winc <- cbind(wsiz[,1:4],t(diff(t(wsiz[,-1:-4]))))
binc <- cbind(bsiz[,1:4],t(diff(t(bsiz[,-1:-4]))))

# merge outcome data
binc <- merge(binc, tbc.target,all.x=TRUE)

bmi.z.0.02 <- by(binc, binc$.imp, function(x) lm(bmi.z.0.02~ao, data = x, na.action='na.omit'))
bmi.z.0.33 <- by(binc, binc$.imp, function(x) lm(bmi.z.0.33~ao, data = x, na.action='na.omit'))
bmi.z.1    <- by(binc, binc$.imp, function(x) lm(bmi.z.1   ~ao, data = x, na.action='na.omit'))
bmi.z.2    <- by(binc, binc$.imp, function(x) lm(bmi.z.2   ~ao, data = x, na.action='na.omit'))
bmi.z.6    <- by(binc, binc$.imp, function(x) lm(bmi.z.6   ~ao, data = x, na.action='na.omit'))
bmi.z.10   <- by(binc, binc$.imp, function(x) lm(bmi.z.10  ~ao, data = x, na.action='na.omit'))
bmi.z.18   <- by(binc, binc$.imp, function(x) lm(bmi.z.18  ~ao, data = x, na.action='na.omit'))
bmi.z.29   <- by(binc, binc$.imp, function(x) lm(bmi.z.29  ~ao, data = x, na.action='na.omit'))

tab.bmi.z.0.02 <- summary(pool(as.mira(bmi.z.0.02)))
tab.bmi.z.0.33 <- summary(pool(as.mira(bmi.z.0.33)))
tab.bmi.z.1    <- summary(pool(as.mira(bmi.z.1)))
tab.bmi.z.2    <- summary(pool(as.mira(bmi.z.2)))
tab.bmi.z.6    <- summary(pool(as.mira(bmi.z.6)))
tab.bmi.z.10   <- summary(pool(as.mira(bmi.z.10)))
tab.bmi.z.18   <- summary(pool(as.mira(bmi.z.18)))
tab.bmi.z.29   <- summary(pool(as.mira(bmi.z.29)))

(bmi.z.0.33 <- summary(pool(as.mira(by(bsiz, bsiz$.imp, function(x) lm(bmi.z.jv~bmi.z.0.33+bmi.z.0.02, data = x, na.action='na.omit'))))))
(bmi.z.1 <- summary(pool(as.mira(by(bsiz, bsiz$.imp, function(x) lm(bmi.z.jv~bmi.z.1+bmi.z.0.33, data = x, na.action='na.omit'))))))
(bmi.z.2 <- summary(pool(as.mira(by(bsiz, bsiz$.imp, function(x) lm(bmi.z.jv~bmi.z.2+bmi.z.1, data = x, na.action='na.omit'))))))
(bmi.z.6 <- summary(pool(as.mira(by(bsiz, bsiz$.imp, function(x) lm(bmi.z.jv~bmi.z.6+bmi.z.2, data = x, na.action='na.omit'))))))
(bmi.z.10 <- summary(pool(as.mira(by(bsiz, bsiz$.imp, function(x) lm(bmi.z.jv~bmi.z.10+bmi.z.6, data = x, na.action='na.omit'))))))
(bmi.z.18 <- summary(pool(as.mira(by(bsiz, bsiz$.imp, function(x) lm(bmi.z.jv~bmi.z.18+bmi.z.10, data = x, na.action='na.omit'))))))

(bmi.z.6 <- summary(pool(as.mira(by(bsiz, bsiz$.imp, function(x) lm(bmi.z.jv~bmi.z.6+bmi.z.2, data = x, na.action='na.omit'))))))
summary(by(bsiz, bsiz$.imp, function(x) lm(bmi.z.jv~bmi.z.6+bmi.z.2, data = x, na.action='na.omit'))[[2]])

# repeat the analysis for the broken stick estimates

bsiz.bs <- as.data.frame(t(t(ranef(fit.bmi)[[1]]) + fixef(fit.bmi)))
dimnames(bsiz.bs)[[2]] <- names(bsiz)[5:13]
binc.bs <- t(diff(t(bsiz.bs)))
bsiz.bs <- data.frame(id=bsiz[bsiz$.imp==1,"id"], bsiz.bs)
binc.bs <- data.frame(id=bsiz[bsiz$.imp==1,"id"], binc.bs)
bsiz.bs <- merge(bsiz.bs, tbc.target)
binc.bs <- merge(binc.bs, tbc.target)

bmi.z.0.02.bs <- lm(bmi.z.0.02~ao, data = binc.bs, na.action='na.omit')
bmi.z.0.33.bs <- lm(bmi.z.0.33~ao, data = binc.bs, na.action='na.omit')
bmi.z.1.bs    <- lm(bmi.z.1   ~ao, data = binc.bs, na.action='na.omit')
bmi.z.2.bs    <- lm(bmi.z.2   ~ao, data = binc.bs, na.action='na.omit')
bmi.z.6.bs    <- lm(bmi.z.6   ~ao, data = binc.bs, na.action='na.omit')
bmi.z.10.bs   <- lm(bmi.z.10  ~ao, data = binc.bs, na.action='na.omit')
bmi.z.18.bs   <- lm(bmi.z.18  ~ao, data = binc.bs, na.action='na.omit')

summary(bmi.z.0.02.bs)
summary(bmi.z.0.33.bs)
summary(bmi.z.1.bs)
summary(bmi.z.2.bs)
summary(bmi.z.6.bs)
summary(bmi.z.10.bs)
summary(bmi.z.18.bs)

### Materials for Table 9.3

a<-round(cor(bsiz[,-(1:4)],use="pair"),2)
b<-round(cor(bsiz.bs,use="pair"),2)

a2<-round(cor(bsiz[!is.na(bsiz$ao),-(1:4)],use="complete.obs"),2)
b2<-round(cor(bsiz.bs[!is.na(bsiz$ao),],use="complete.obs"),2)


# Import data
library(idar)
data(diet)

# Compute weight loss
diet$weight.loss = diet$initial.weight - diet$final.weight

# Variables of interest
dietA = diet$weight.loss[diet$diet.type=="A"]
dietC = diet$weight.loss[diet$diet.type=="C"]

# Boxplots
boxplot_w_points(dietA, dietC, xlab = "Weight loss (kg)", horizontal = T)
abline(v = 0)


#' Calculate common descriptive statistics
#'
#' \code{describe_data} returns a set of common descriptive statistics
#' (e.g., n, mean, sd) for numeric variables.
#'
#' @param data A data frame.
#' @param column An unquoted (numerical) column name from the data frame.
#' @param na.rm Logical. Should missing values (including NaN) be excluded in
#' calculating the descriptives? The default is TRUE.
#' @param short Logical. Should only a subset of descriptives be reported? If
#' set to TRUE, only the N, M, and SD will be returned. The default is FALSE.
#'
#' @details The data can be grouped using \code{dplyr::group_by} so that
#' descriptives will be calculated for each group level.
#'
#' When na.rm is set to FALSE, a percentage column will be added to the output
#' that contains the percentage of non-missing data.
#'
#' Skew and kurtosis are based on the \code{skewness} and \code{kurtosis}
#' functions of the \code{moments} package (Komsta & Novomestky, 2015).
#'
#' Percentages are calculated based on the total of non-missing observations.
#' When na.rm is set to FALSE, percentages are based on the total of missing and
#' non-missing observations.
#'
#' @examples
#' # Load the dplyr package for access to the %>% operator and group_by()
#' library(dplyr)
#'
#' # Inspect descriptives of the response column from the 'quote_source' data
#' # frame included in tidystats
#' describe_data(quote_source, response)
#'
#' # Repeat the former, now for each level of the source column
#' quote_source %>%
#'   group_by(source) %>%
#'   describe_data(response)
#'
#' # Only inspect the total N, mean, and standard deviation
#' quote_source %>%
#'   group_by(source) %>%
#'   describe_data(response, short = TRUE)
#'
#' @importFrom dplyr %>%
#'
#' @export
describe_data <- function(data, column, na.rm = TRUE, short = FALSE) {

  # Check if 'data' is actually a data frame
  if (!"data.frame" %in% class(data)) {
    stop("'data' is not a data frame.")
  }

  # Check if the user specified a column
  if (missing(column)) {
    stop("No column found; please provide one.")
  }

  # Check whether the values in var are numeric
  if (sum(!class(dplyr::pull(data, {{ column }})) %in%
      c("numeric", "integer")) > 0) {
    stop("The column does not contain numeric values.")
  }

  # Get grouping
  grouping <- dplyr::group_vars(data)

  # Select only the variable and grouping columns from the data
  data <- dplyr::select(data, dplyr::group_vars(data), {{ column }})

  # Calculate descriptives
  output <- data %>%
    dplyr::summarize(
      missing  = sum(is.na({{ column }})),
      N        = dplyr::n() - missing,
      M        = mean({{ column }}, na.rm = na.rm),
      SD       = sd({{ column }}, na.rm = na.rm),
      SE       = SD / sqrt(N),
      min      = min({{ column }}, na.rm = na.rm),
      max      = max({{ column }}, na.rm = na.rm),
      range    = diff(range({{ column }}, na.rm = na.rm)),
      median   = median({{ column }}, na.rm = na.rm),
      mode     = unique({{ column }})[which.max(tabulate(match({{ column }},
        unique({{ column }}))))],
      skew     = (sum(({{ column }} - mean({{ column }}, na.rm = na.rm))^3,
        na.rm = na.rm) / N) / (sum(({{ column }} -
            mean({{ column }}, na.rm = na.rm))^2, na.rm = na.rm) /
            N)^(3 / 2),
      kurtosis = N * sum(({{ column }} - mean({{ column }}, na.rm = na.rm))^4,
        na.rm = na.rm) / (sum(({{ column }} - mean({{ column }},
          na.rm = na.rm))^2, na.rm = na.rm)^2),
      .groups = "keep"
    )

  output <- dplyr::mutate(output,
      var = dplyr::quo_name(dplyr::enquo(column))
    )
  # TODO: See if this can be done differently

  # Add percentage if na.rm = FALSE (if na.rm = TRUE it would always be 100)
  # Note that depending on the value of na.rm, we either ignore or include the
  # number of missing observations
  if (!na.rm) {
    output <- dplyr::mutate(output, pct = N / sum(N + missing) * 100)
  }

  # Reorder the columns and return only a subset if short was set to TRUE
  if (short) {
    output <- dplyr::select(output, var, dplyr::all_of(grouping), N, M, SD)
  } else {
    output <- dplyr::select(output, var, dplyr::all_of(grouping),
      missing, N, dplyr::contains("pct"), dplyr::everything())
  }

  # Add a tidystats class so we can use the tidy_stats() function to parse the
  # the output
  # Put it at the beginning otherwise we get an error when printing the tibble
  class(output) <- c("tidystats_descriptives", class(output))

  return(output)
}


library(tidyverse)
library(readxl)
library(knitr)

race_data <- read.csv("./data/Race Data Entry - CRDT.csv")
county_age_cases <-
  read_excel("./data/PUBLIC_CDC_EVENT_DATE_SARS.xlsx", sheet = 1)

# Weekly new cases by age group in WA
weekly_cases_by_age <- county_age_cases %>%
  group_by(Date = WeekStartDate) %>%
  summarize(`Age 0-19` = sum(`Age 0-19`),
            `Age 20-39` = sum(`Age 20-39`),
            `Age 40-59` = sum(`Age 40-59`),
            `Age 60-79` = sum(`Age 60-79`),
            `Age 80+` = sum(`Age 80+`))

#AVerage weekly new cases by age group in WA
avg_weekly_cases_age <- weekly_cases_by_age %>%
  select(`Age 0-19`,
         `Age 20-39`,
         `Age 40-59`,
         `Age 60-79`,
         `Age 80+`) %>%
  gather(key = age_group, value = weekly_cases)

# Cumulative total cases of COVID by racial group in WA
cumulative_cases_by_race <- race_data %>%
  group_by(State) %>%
  filter(State == "WA") %>%
  arrange(Date) %>%
  summarize(Date = as.Date(as.character(Date), format = "%Y%m%d"),
            White = Cases_White,
            Black = Cases_Black,
            "Hispanic/Latino" = Cases_LatinX,
            Asian = Cases_Asian,
            "American Indian/Alaska Native" = Cases_AIAN,
            "Native Hawaiian/Pacific Islander" = Cases_NHPI,
            Multiracial = Cases_Multiracial,
            Other = Cases_Other,
            Unknown = Cases_Unknown) %>%
  filter(State == "WA") %>%
  # Excluded first 9 rows due to irregularity
  slice(- (1:9))

# Rate of increase of new COVID cases by racial group in WA (percent)
rate_cases_by_race <- race_data %>%
  group_by(State) %>%
  arrange(Date) %>%
  summarize(Date = as.Date(as.character(Date), format = "%Y%m%d"),
            White = ((as.numeric(Cases_White) - as.numeric(
              lag(Cases_White))) / as.numeric(lag(Cases_White))) * 100,
            Black = ((as.numeric(Cases_Black) - as.numeric(
              lag(Cases_Black))) / as.numeric(lag(Cases_White))) * 100,
            "Hispanic/Latino" = ((as.numeric(Cases_LatinX) - as.numeric(
              lag(Cases_LatinX))) / as.numeric(lag(Cases_LatinX))) * 100,
            Asian = ((as.numeric(Cases_Asian) - as.numeric(
              lag(Cases_Asian))) / as.numeric(lag(Cases_Asian))) * 100,
            "American Indian/Alaska Native" = ((
              as.numeric(Cases_AIAN) - as.numeric(
                lag(Cases_AIAN))) / as.numeric(lag(Cases_AIAN))) * 100,
            "Native Hawaiian/Pacific Islander" = ((
              as.numeric(Cases_NHPI) - as.numeric(
                lag(Cases_NHPI))) / as.numeric(lag(Cases_NHPI))) * 100,
            Multiracial = ((
              as.numeric(Cases_Multiracial) - as.numeric(
                lag(Cases_Multiracial))) / as.numeric(
                  lag(Cases_Multiracial))) * 100,
            Other = ((as.numeric(Cases_Other) - as.numeric(
              lag(Cases_Other))) / as.numeric(lag(Cases_Other))) * 100,
            Unknown = ((as.numeric(Cases_Unknown) - as.numeric(
              lag(Cases_Unknown))) / as.numeric(lag(Cases_Unknown))) * 100) %>%
  mutate_if(is.numeric, round, digits = 1) %>%
  filter(State == "WA") %>%
  # Excluded first 9 rows due to irregularity
  slice(- (1:9))


#Adquisicion de datos a partir de un dataset
archivo <- read.csv("/home/valeria/Escritorio/BitcoinDataset.csv")
archivo
nrow(archivo)
ncol(archivo)

archivo2 <- read.csv("/home/valeria/Escritorio/EthereumDataset.csv")

nrow(archivo2)
ncol(archivo2)

#Conocimeinto de la estructura del archivo csv
str(archivo)

str(archivo2)
# names(archivo)<- c("Fecha","Precio_promedio", "Bitcoins_minado","Precio_circulacion","Precio_compraventa", "Size_bloque_headersTransa",
# "Promedio_sizeMB", "Blocks_Mined", "Promedio_transacciones_bloque", "Time_transaccion","Terapersecond_Bitcoin","Dificultad_nuevobloque",
# "Pagos_mineros","Valortotal_mineros","Ingresos_mineros","IngresosMineros_entretransacciones"," Direcciones_BitcoinBlockc",
# "Transacciones_diarias","Total_trasacciones","Exlusion_popular","Transacciones_largas","Total_transacciones_dia","Transacciones_blockchain",
# "Estimacion_Transacciones_Dolar")

head(archivo)
head(archivo2)
#--------------------------
#Se desecha informacion si llega a contener un campo "NA"
archivo<-na.omit(archivo)
str(archivo)
archivo2<-na.omit(archivo2)
#conocer si existen relaciones lineales entre datos
#Como se visualizan muchas graficas es necesario agrandar el panel donde se visualizan los plots(casi al maximo)
#Para poder visualizar los resultados
pairs(archivo)
pairs(archivo2)

#Se grafica la correlation que tienen los datos entre ellos
#Como se visualizan muchas graficas es necesario agrandar el panel donde se visualizan los plots(casi al maximo)
#Para poder visualizar los resultados
library(corrplot)
correlacion <- cor(archivo[,2:24])
corrplot(correlacion)
getwd()

head(archivo)
ncol(archivo)

#Para que exista una estrecha relacion entre datos su correlacion debe tener un valor cercano a 1
##-----------------------------------

##Grafica que muestra el precio del bitcoin a traves del tiempo
plot(archivo$Date,archivo$btc_market_price, main="Precio a través del tiempo", ylab="Precio", xlab="Fecha")
## Modelo de regresión lineal entre Precio promedio en dólares en las principales bolsas de bitcoins
# y El valor total en dólares del suministro de bitcoin en circulación.
mod<-lm(btc_market_price~btc_market_cap, data=archivo)
summary(mod)
#la intercepción es 3.78, lo que significa que cuando el valor total en USD del suministro de Bitcoin en circulación es 0, se predice que el precio promedio del mercado en USD a través de las principales bolsas de bitcoin será $3.78
#pendiente es 5.95, nos dice que predecimos que el precio de mercado promedio en USD en las principales bolsas de bitcoin aumentará en 5.95 $ por cada aumento adicional de dólares en el valor total en USD del suministro de bitcoins en circulación

mod1<-lm(btc_market_price~btc_estimated_transaction_volume_usd, data=archivo)
summary(mod1)

#intercept es 7, lo que significa que cuando el valor estimado de transacción en valor USD es 0, se predice que el precio promedio del mercado USD en las principales bolsas de bitcoins será 7 $.
# pendiente es 3.9, nos dice que predecimos que el precio promedio del mercado en USD en las principales bolsas de bitcoins aumentará en 3.9 $ por cada aumento adicional en el valor estimado de transacción.

#-------------Entrenamiento

set.seed(1)
train.index<-sample(1:nrow(archivo),0.70*nrow(archivo), replace=FALSE)
train <- archivo[train.index, ]
test  <- archivo[-train.index,]

#Entrenamiento del dataset y realizar la prediccion del precio, respecto al valor total en USD del volumen de
#negociacion en las principales bolsas de bitcoins.
model1 <- lm(btc_market_price~btc_trade_volume , train)
summary(model1)
p1 <- predict(model1,test)
p1
#head(p1)
error1 <- p1 - test[["btc_market_price"]]
error1
sqrt(mean(error1^2))
plot(p1, main="Prediccion 1")
#RMSE=977.2906

#Modelo para la relacion del precio con el valor total en dólares del suministro de bitcoin en circulación.

  model2 <- lm(btc_market_price~btc_market_cap, train)
  summary(model2)
  p2 <- predict(model2,test)
  head(p2)
  error2 <- p2 - test[["btc_market_price"]]
  sqrt(mean(error2^2))
  plot(p2, main= "Prediccion 2")
  #RMSE=51.17771

#-------------------

# Principal Componente de Analisis en el mercado de Bitcoin
library(FactoMineR)
pc1<-PCA(archivo[,2:24],scale.unit = TRUE, ncp = 23, graph = TRUE)
summary(pc1)
a<-dimdesc(pc1,axes = c(1:2))
a$Dim.1
a$Dim.2

pc<-prcomp(BTC[,c("btc_market_price","btc_miners_revenue")], center = T, scale=T)
summary(pc)
head(pc$x)
#we can see that the first principal component explains about 61.6% of the total variation, and the second principal component an additional 10.98%.
#btc_n_transactions_total and btc_blocks_size  are the most contributing variables

model3<-lm(btc_market_price~btc_n_transactions_total, data=BTC)
summary(model3)
p3 <- predict(model3,test)
error3 <- p3 - test[["btc_market_price"]]
sqrt(mean(error3^2))
#RMSE=616.3098
#intercept is -1.16, which means that when total number of transactions is 0, the average USD market price across major bitcoin exchanges is predicted to be -1.
# slope is  9.8,  it tells us that we predict the average USD market price across major bitcoin exchanges to increase by 9.8$ for every additional dollar increase in total number of transactions.

model4<-lm(btc_market_price~btc_n_transactions_total+btc_avg_block_size+btc_difficulty+btc_output_volume, data=BTC)
summary(model4)
#Multiple R-squared:  0.9112,	Adjusted R-squared:  0.9111 , all independent variables affect the dependent one.
p4 <- predict(model4,test)
error4 <- p4 - test[["btc_market_price"]]
sqrt(mean(error4^2))
#RMSE=295.8589


suppressMessages(library(cop))

x = matrix(1:4, 2) + 10*comm.rank()

add = function(a, b) a+b
out_all = cop_allreduce(x, op=add, commutative=TRUE)
out = cop_reduce(x, op=add, commutative=TRUE)

mpi_cat("\ninput:\n", quiet=TRUE)
mpi_print(x, all.rank=TRUE)

mpi_cat("\nfunction:\n", quiet=TRUE)
mpi_print(add)
mpi_cat("\noutput_all:\n", quiet=TRUE)
mpi_print(out_all, all.rank=TRUE)
mpi_cat("\noutput:\n", quiet=TRUE)
mpi_print(out, all.rank=TRUE)

R = function(a, b) qr.R(qr(rbind(a, b)))
out_all = cop_allreduce(x, op=R, commutative=TRUE)
out = cop_reduce(x, op=R, commutative=TRUE)

mpi_cat("\nfunction:\n", quiet=TRUE)
mpi_print(R)
mpi_cat("\noutput_all:\n", quiet=TRUE)
mpi_print(out_all, all.rank=TRUE)
mpi_cat("\noutput:\n", quiet=TRUE)
mpi_print(out, all.rank=TRUE)

finalize()


library(EpiNow2)
library(tidyverse)
library(lubridate)
reporting_delay <- estimate_delay(rlnorm(1000, log(2), 1),
                                  max_value = 15, bootstraps = 1)
reporting_delay <- list(
  mean = convert_to_logmean(2, 1), mean_sd = 0.1,
  sd = convert_to_logsd(2, 1), sd_sd = 0.1,
  max = 10
)
generation_time <- get_generation_time(disease = "SARS-CoV-2", source = "ganyani")
incubation_period <- get_incubation_period(disease = "SARS-CoV-2", source = "lauer")

reported_cases <- read_csv("E:\\Pythonfiles\\Github_Programs\\EstmatingRtDeepL\\Rt_Methods_Comparision\\ontario_cases.csv")
reported_cases$date <- ymd(reported_cases$date)
head(reported_cases)

estimates <- epinow(reported_cases = reported_cases,
                    generation_time = generation_time,
                    delays = delay_opts(incubation_period, reporting_delay),
                    rt = rt_opts(prior = list(mean = 2, sd = 0.2)),
                    stan = stan_opts(cores = 4))

names(estimates)

knitr::kable(summary(estimates))
Rt <- summary(estimates, type = "parameters", params = "R")

head(Rt)

write_csv(Rt, "ontario_epinow2_rt.csv")

It <- summary(estimates, output = "estimated_reported_cases")

head(It)

write_csv(It, "ontario_epinow2_It.csv")

plot(estimates)


 DTGSJA Example Program Results

 Number of infinite generalized singular values (K)
     1
 Number of finite generalized singular values (L)
     2
  Effective Numerical rank of (A**T B**T)**T (K+L)
     3

 Finite generalized singular values
     1.3151E+00  8.0185E-02

 Orthogonal matrix U
              1           2           3           4
 1  -1.3484E-01  5.2524E-01 -2.0924E-01  8.1373E-01
 2   6.7420E-01 -5.2213E-01 -3.8886E-01  3.4874E-01
 3   2.6968E-01  5.2757E-01 -6.5782E-01 -4.6499E-01
 4   6.7420E-01  4.1615E-01  6.1014E-01  1.5127E-15

 Orthogonal matrix V
              1           2
 1   3.5539E-01 -9.3472E-01
 2   9.3472E-01  3.5539E-01

 Orthogonal matrix Q
              1           2           3
 1  -8.3205E-01 -9.4633E-02 -5.4657E-01
 2   5.5470E-01 -1.4195E-01 -8.1985E-01
 3   0.0000E+00 -9.8534E-01  1.7060E-01

 Nonsingular upper triangular matrix R
              1           2           3
 1  -2.0569E+00 -9.0121E+00 -9.3705E+00
 2              -1.0882E+01 -7.2688E+00
 3                          -6.0405E+00

 Number of cycles of the Kogbetliantz method
     2


#' Calculate link position vectors
#'
#' Counts the number of times each link in a network occurs in each unique link position within the motifs
#' @param M A numeric matrix representing interactions between two groups of nodes. Each row corresponds to a node in one level
#' and each column corresponds to a node in the other level. Elements of M are positive numbers if nodes interact, and 0
#' otherwise. Formally, M is a biadjacency matrix. When nodes i and j interact, m_ij > 0; if they do not interact, m_ij = 0.
#'
#' @param six_node Logical; should positions in six node motifs be counted? Defaults to FALSE.
#' @param weights Logical; Should weights of the links be taken into account?
#' @param normalisation Which normalisation should be used: 'none','sum', 'position', 'sizeclass', 'sizeclass_plus1', 'sizeclass_NAzero', 'levelsize', 'levelsize_plus1', 'levelsize_NAzero','motif', 'motif_plus1' or 'motif_NAzero'?  Defaults to "none". (see details)
#' @details Counts the number of times each link in a network occurs in each of the 29 (if \code{six_node} = FALSE) or 106 (if \code{six_node} = TRUE) unique link positions within motifs (to quantify a link's structural role).
#' If \code{six_node} = FALSE, link positions in all motifs containing between 2 and 5 nodes are counted. If \code{six_node} = TRUE, link positions in all motifs containing between 2 and 6 nodes are counted. Analyses where \code{six_node} = FALSE are substantially faster
#' than when \code{six_node} = TRUE, especially for large networks. For large networks, counting six node motifs is also memory intensive. In some cases, R can crash if there is not enough memory.
#'
#' If interactions are weighted (non-zero matrix elements take values other than 1), these can be incorporated by setting \code{weights = TRUE}.
#' If \code{weights = TRUE}, the function will return the number of times each link occurs in each position,
#' multiplied by the weight of the link, following Mora et al. (2018).
#'
#' Links between nodes with more interactions will tend to appear in more positions. Normalisation helps control for this effect. bmotif include four types of normalisation:
#' \itemize{
#'  \item{\strong{"none"}: performs no normalisation and will return the raw position counts.}
#'  \item{\strong{"sum"}: divides the position measure for each link by the total number of times that link appears in any position (divides each element in a row by the row sum).}
#'  \item{\strong{"position"}: divides the position measure for each link by the total number of times any link occurs in that link position (divides each element in a column by the column sum). This gives a measure of how often a link occurs in a position relative to the other links in the network.}
#'  \item{\strong{Size class normalisation}
#'  \itemize{
#'  \item{\strong{"sizeclass"}: divides the position measure for each link by the total number of times that link appears in any position within the same motif size class (the number of nodes a motif contains).}
#'  \item{\strong{"sizeclass_plus1"}: same as 'sizeclass' but adds one to all position measure values. If a link does not occur in any motifs in a given size class, 'sizeclass' normalisation
#'  will return NAs. 'sizeclass_plus1' avoids this by adding one to all counts.}
#'  \item{\strong{"sizeclass_NAzero"}: same as 'sizeclass' but replaces all NA values with 0. If a link does not occur in any motifs in a given size class, 'sizeclass' normalisation
#'  will return NAs. 'sizeclass_NAzero' avoids this by replacing NAs with zero.}
#'  }
#'  }
#'  \item{\strong{Levelsize normalisation}
#'  \itemize{
#'  \item{\strong{"levelsize"}: divides the position measure for each link by the total number of times that link appears in any position within a motif with a given number of nodes in the top level and the bottom level.
#'  For example, the relative frequencies of all position measures in motifs with three nodes in the top level and two nodes in the bottom level will sum to one, as will the relative frequency of all position measures in motifs with 2 nodes in the top level and
#'  two nodes in the bottom level, and so on.}
#'  \item{\strong{"levelsize_plus1"}: same as 'levelsize' but adds one to all position measure values. If a link does not occur in any motifs with a given number of nodes in the top level and the bottom level, 'levelsize' normalisation
#'  will return NAs. 'levelsize_plus1' avoids this by adding one to all counts.}
#'  \item{\strong{"levelsize_NAzero"}: same as 'levelsize' but replaces all NA values with 0. If a link does not occur in any motifs with a given number of nodes in the top level and the bottom level, 'levelsize' normalisation
#'  will return NAs. 'levelsize_NAzero' avoids this by replacing NAs with zero.}
#'  }
#'  }
#'  \item{\strong{Motif normalisation}
#'  \itemize{
#'  \item{\strong{"motif"}: divides the position measure for each link by the total number of times that link appears in any position within the same motif.
#'  For example, the relative frequencies of all position measures in motif 5 will sum to one, as will the relative frequency of all position measures in motif 10, and so on.}
#'  \item{\strong{"motif_plus1"}: same as 'motif' but adds one to all position measure values. If a link does not occur in a particular motif, 'motif' normalisation
#'  will return NAs. 'motif_plus1' avoids this by adding one to all counts.}
#'  \item{\strong{"motif_NAzero"}: same as 'motif' but replaces all NA values with 0. If a link does not occur in a particular motif, 'levelsize' normalisation
#'  will return NAs. 'motif_NAzero' avoids this by replacing NAs with zero.}
#'  }
#'  }
#'  }
#'
#' If a matrix is provided without row or column names, default names will be assigned: the first row will be called called 'r1', the second row will be called 'r2' and so on. Similarly, the first column will be called 'c1', the second column will be called 'c2' and so on.
#'
#' @return  Returns a data frame with one column for each link position: 29 columns if \code{six_node} is FALSE, and 106 columns if \code{six_node} is TRUE.
#' Columns names are given as "lpx" where x is the ID of the position as described in the motif dictionary. \strong{To view the 'motif dictionary' showing
#' which link position a given ID corresponds to, enter \code{vignette("bmotif-dictionary")}.}
#'
#' Each row corresponds to one link in the network. Row names are gives as "x -- y", where x is the species in the first level (rows) and y is the species in the second level (columns).
#'
#' By default, the elements of the data frame will be the raw link position counts.
#' If \code{weight = TRUE}, link position counts will be multiplied by the link weight.
#' If \code{normalisation} is set to "sum", "sizeclass" or "position", the elements will be
#' normalised position counts as described above.
#'
#' @export
#' @references
#' Mora, B.B., Cirtwill, A.R. and Stouffer, D.B., 2018. pymfinder: a tool for the motif analysis of binary and quantitative complex networks. bioRxiv, 364703.
#'
#' Simmons, B. I., Sweering, M. J. M., Dicks, L. V., Sutherland, W. J. and Di Clemente, R. bmotif: a package for counting motifs in bipartite networks. bioRxiv. doi: 10.1101/302356
#' @examples
#' set.seed(123)
#' row <- 10
#' col <- 10
#'
#' # link positions in a binary network
#' m <- matrix(sample(0:1, row*col, replace=TRUE), row, col)
#' link_positions(M = m, six_node = TRUE, weights = FALSE, normalisation = "none")
#'
#' # link positions in a weighted network
#' m[m>0] <- stats::runif(sum(m), 0, 100)
#' link_positions(M = m, six_node = TRUE, weights = TRUE, normalisation = "none")

link_positions <- function(M, six_node = FALSE, weights, normalisation = "none") {
  # M is the adjacence matrix

  # check inputs
  if(inherits(M, "matrix") != TRUE){stop("'M' must be an object of class 'matrix'")} # make sure M is a matrix
  if(!all(apply(M, 1:2, is.numeric))){stop("Elements of 'M' must be numeric")} # make sure all elements of M are numbers
  if(!all(apply(M, 1:2, function(x) length(x) > 0))){stop("Elements of 'M' cannot have length zero")} # make sure no elements of M have 0 length e.g. numeric(0)
  if(!all(apply(M, 1:2, function(x) x >= 0))){stop("Elements of 'M' must be greater than or equal to zero")} # make sure all elements of M are >= zero
  if(all(apply(M, 1:2, function(x) x == 0))){stop("The matrix has no links (all elements are zero)")} # make sure M has some links
  if(inherits(six_node,"logical") != TRUE){stop("'six_node' must be of class 'logical' i.e. TRUE or FALSE")} # make sure six_node is logical i.e. TRUE or FALSE
  if(inherits(normalisation,"character") != TRUE){stop("'normalisation' must be of class 'character'")} # make sure 'normalisation' is a character
  if(!normalisation %in% c("none","sum","sizeclass", "sizeclass_plus1", "sizeclass_NAzero","levelsize", "levelsize_plus1", "levelsize_NAzero", "motif", "motif_plus1", "motif_NAzero","position")){
    stop("'normalisation' must equal 'none','sum', 'position', 'sizeclass', 'sizeclass_plus1', 'sizeclass_NAzero', 'levelsize', 'levelsize_plus1', 'levelsize_NAzero','motif', 'motif_plus1' or 'motif_NAzero'")
  }
  if(any(duplicated(rownames(M))) | any(duplicated(colnames(M)))){stop("Input matrix must not have duplicate row or column names")}
  if((normalisation == "sum" | normalisation == "sizeclass" | normalisation == "levelsize" | normalisation == "motif") & weights == TRUE){warning("Please note that with 'sum', 'sizeclass', 'levelsize' or 'motif' normalisation, the results won't change if weights are taken into account. This is because when weights = TRUE, each row of the output is multiplied by a fixed factor (the link's weight) and therefore the relative proportions are the same as if weights were not considered. Consider setting normalisation to 'position' or 'none'.")}

  W <- M # store copy of weighted matrix
  M[M > 0] <- 1 # ensure M is binary

  # compute auxiliary stuff
  NZ = nrow(M) # this is just Z in the latex file, but Z is also a matrix later
  NP = ncol(M) # this is just P in the latex file, but P is also a matrix later
  jZ = as.matrix(rep(1, NZ))
  jP = as.matrix(rep(1, NP))

  J <- matrix(rep(1, NZ * NP), nrow = NZ, ncol = NP) # Z x P matrix of ones
  JP <- matrix(rep(1, NP * NP), nrow = NP, ncol = NP) # P x P matrix of ones
  JZ <- matrix(rep(1, NZ * NZ), nrow = NZ, ncol = NZ) # Z x Z matrix of ones

  JT <- t(J) # transpose of J, P x Z matrix of ones
  MT <- t(M) # transpose of M
  N <- J - M # complement of M
  NT <- t(N) # transpose of the complement of M

  dZ = M %*% jP
  dP = MT %*% jZ

  V = matrix(rep(dZ, each = NP), nrow = NP, ncol = NZ, byrow = FALSE)
  U = matrix(rep(dP, times = NZ), nrow = NP, ncol = NZ, byrow = FALSE)

  # matrices like in the formulae
  Z <- M %*% MT
  Y <- M %*% NT
  X <- N %*% MT

  P <- MT %*% M
  Q <- MT %*% N
  R <- NT %*% M

  ##########################

  # now compute positions
  # possibly put this in a separate function later

  # create a data frame
  # each row corresponds to one edge in the graph
  # order: (1,1), (1,2), (1,3), ...(1,P), (2,1), ..., (2,P), ..., (Z,1), ..., (Z,P)
  # each column corresponds to an edge position, i.e. column p3 gives count for link position 3

  # note: the as.vector() command is not strictly needed
  # since R even converts the matrix automatically into a vector if we assign a matrix to a column like below

  k = 29 + (six_node) * (106 - 29) # k depends on whether 6 species are wanted or not

  lp <- matrix(rep (-1, k* NZ * NP), ncol = k)

  ######

  names <- rep("", NZ * NP)

  if (is.null(rownames(M))) {
    class1_names <- paste0("r", 1:NZ)
  } else {
    class1_names <- rownames(M)
  }
  if (is.null(colnames(M))) {
    class2_names <- paste0("c", 1:NP)
  } else {
    class2_names <- colnames(M)
  }

  for (i in 1:NZ) {
    for (j in 1:NP) {
      names[(i - 1)* NP + j] <- name_edge(class1_names[i], class2_names[j])
    }
  }
  rownames(lp) <- names

  if (six_node) {
    colnames(lp) <- paste('lp', 1:106, sep = '')
  }
  if (!six_node) {
    colnames(lp) <- paste('lp', 1:29, sep = '')
  }

  # want to compute only for present edges
  # so make a list of all the edges present in the network
  # column one is just a numbering
  # column 2 is the index of the row vertex, column 3 the index of the column vertex
  # for later use, if weights = TRUE, also store the weight of the link in column 4
  ct <- 0
  E <- sum(M) # number of edges

  if (six_node & !weights) {
    edges <- matrix(rep(0,3*E), nrow = E)
    for (i in 1:NZ) {
      for (j in 1:NP) {
        if (M[i,j] == 1) {
          ct <- ct + 1
          edges[ct,1] <- ct
          edges[ct,2:3] <- c(i, j)
        }
      }
    }
  }

  if (weights) {
    edges <- matrix(rep(0,4*E), nrow = E)
    for (i in 1:NZ) {
      for (j in 1:NP) {
        if (M[i,j] == 1) {
          ct <- ct + 1
          edges[ct,1] <- ct
          edges[ct,2:3] <- c(i, j)
          edges[ct, 4] <- W[i,j]
        }
      }
    }
  }

  # ------- PUT IN VALUES
  # up to 4 species

  lp[,1] <- as.vector(t(M))
  lp[,2] <- as.vector(V - JT)

  lp[,3] <- as.vector(U - JT)
  lp[,4] <- 0.5*as.vector((U - JT)*(U-2*JT))
  lp[,5] <- as.vector(NT %*% Z)
  lp[,6] <- as.vector(MT %*% Y)
  lp[,7] <- as.vector(MT %*% X)
  lp[,8] <- as.vector(MT %*% (Z - JZ) - V + JT)
  lp[,9] <- 0.5*as.vector((V - JT)*(V - 2*JT))

  # 5 species

  lp[,10] <- 1/6 * as.vector((U - JT)*(U - 2*JT) * (U - 3*JT))
  lp[,11] <- 0.5 * as.vector(t((M %*% (Q * (Q - JP)))))
  lp[,12] <- as.vector(t(N %*% (P * (R - JP))))
  lp[,13] <- 0.5 * as.vector(t(M %*% (R * (R - JP))))
  lp[,14] <- as.vector(t(N %*% (P * Q)))
  lp[,15] <- as.vector(t(M %*% (Q * R)))
  lp[,16] <- as.vector(t(M %*% (Q * (P - JP))))
  lp[,17] <- 0.5 * as.vector(t(N %*% (P * (P - JP))))
  lp[,18] <- as.vector(t(M %*% (R * (P - JP))))
  lp[,19] <- 0.5 * as.vector(t(M %*% ( (P - JP) * (P - 2*JP))) - (U - JT) * (U - 2*JT) )
  lp[,20] <- as.vector(NT %*% (Z * (X - JZ)))
  lp[,21] <- 0.5 * as.vector(MT %*% (Y * (Y - JZ)))
  lp[,22] <- 0.5 * as.vector(MT %*% (X * (X - JZ)))
  lp[,23] <- as.vector(NT %*% (Z * Y))
  lp[,24] <- as.vector(MT %*% (X * Y))
  lp[,25] <- 0.5 * as.vector(NT %*% (Z * (Z - JZ)))
  lp[,26] <- as.vector(MT %*% (Y * (Z - JZ)))
  lp[,27] <- as.vector(MT %*% (X * (Z - JZ)))
  lp[,28] <- 0.5 * as.vector(MT %*% ( (Z - JZ) * (Z - 2*JZ) ) - (V - JT) * (V - 2*JT))
  lp[,29] <- 1/6 * as.vector((V - JT) * (V - 2*JT) * (V - 3*JT))

  # 6 species
  if (six_node) {
    lp[,30] <- 1/24 * as.vector((U - JT) * (U - 2*JT) * (U - 3*JT) * (U - 4*JT))
    lp[,31] <- 1/6 * as.vector(t(M %*% (Q * (Q - JP) * (Q - 2*JP))))
    lp[,32] <- 1/2 * as.vector(t(N %*% ((R - JP) * (R - 2*JP) * P)))
    lp[,33] <- 1/6 * as.vector(t(M %*% (R * (R - JP) * (R - 2*JP))))
    lp[,34] <- 1/2 * as.vector(t(N %*% (Q * (Q - JP) * P)))
    lp[,35] <- 1/2 * as.vector(t(M %*% (Q * (Q - JP) * R)))
    lp[,36] <- as.vector(t(N %*% (Q * P * (R - JP))))
    lp[,37] <- 1/2 * as.vector(t(M %*% (R * (R - JP) * Q)))
    lp[,38] <- 1/2 * as.vector(t(M %*% (Q * (Q - JP) * (P - JP))))
    lp[,39] <- 1/2 * as.vector(t(N %*% (P * (P - JP) * (R - JP))))
    lp[,40] <- 1/2 * as.vector(t(M %*% (R * (R - JP) * (P - JP))))
    lp[,41] <- 1/2 * as.vector(t(N %*% (P * (P - JP) * Q)))
    lp[,42] <- as.vector(t(M %*% ((P - JP) * Q * R)))
    lp[,43] <- 1/2 * as.vector(t(M %*% ((P- JP) * (P - 2*JP) * Q)))
    lp[,44] <- 1/6 * as.vector(t(N %*% (P* (P - JP) * (P - 2*JP))))
    lp[,45] <- 1/2 * as.vector(t(M %*% ((P- JP) * (P - 2*JP) * R)))
    lp[,46] <- 1/6 * as.vector(t(M %*% ((P- JP) * (P - 2*JP) * (P - 3* JP))) - ((U - JT) * (U - 2*JT) * (U - 3*JT)))

    lp[,90] <- 1/2 * as.vector(NT %*% ((X - JZ) * (X - 2*JZ) * Z))
    lp[,91] <- 1/6 * as.vector(MT %*% (Y * (Y - JZ) * (Y - 2*JZ)))
    lp[,92] <- 1/6 * as.vector(MT %*% (X * (X - JZ) * (X - 2*JZ)))
    lp[,93] <- 1/2 * as.vector(NT %*% (Z * Y * (Y - JZ)))
    lp[,94] <- as.vector(NT %*% (Z * Y * (X - JZ)))
    lp[,95] <- 0.5 * as.vector(MT %*% (X * Y * (Y - JZ)))
    lp[,96] <- 0.5 * as.vector(MT %*% (Y * X * (X - JZ)))
    lp[,97] <- 0.5 * as.vector(NT %*% ((X - JZ) * Z * (Z - JZ)))
    lp[,98] <- 0.5 * as.vector(MT %*% ((Z - JZ) * Y * (Y - JZ)))
    lp[,99] <- 0.5 * as.vector(MT %*% ((Z - JZ) * X * (X - JZ)))
    lp[,100] <- 0.5 * as.vector(NT %*% (Z * (Z - JZ) * Y))
    lp[,101] <- as.vector(MT %*% (X * Y * (Z - JZ)))
    lp[,102] <- 1/6 * as.vector(NT %*% (Z * (Z - JZ) * (Z - 2*JZ)))
    lp[,103] <- 0.5 * as.vector(MT %*% (Y * (Z - JZ) * (Z - 2*JZ)))
    lp[,104] <- 0.5 * as.vector(MT %*% (X * (Z - JZ) * (Z - 2*JZ)))
    lp[,105] <- 1/6 * as.vector(MT %*% ((Z - JZ) * (Z - 2*JZ) * (Z - 3*JZ)) - ((V - JT) * (V - 2*JT) * (V - 3*JT)))
    lp[,106] <- 1/24 * as.vector((V - JT) * (V - 2*JT) * (V - 3*JT) * (V - 4*JT))

    # ---------- TENSOR CASES

    # now clean rows where the edge is not present
    lp <- subset(lp, lp[,1] == 1)

    if (NP >= NZ) { # NP > NZ
      JZ3 <- array(rep(1, NZ * NZ * NZ), c(NZ, NZ, NZ)) # Z x Z x Z array of ones
      KZ3 <- JZ3 # Z x Z x Z matrix, 0 if two indices are equal, 1 otherwise
      for (i in 1 : NZ){
        for (j in 1 : NZ){
          KZ3[i,j,j] <- 0
          KZ3[j,i,j] <- 0
          KZ3[j,j,i] <- 0
        }
      }

      # auxiliary matrices to create A, ..., G
      AP <- maketensor(MT, MT)
      BP <- maketensor(MT, NT)
      CP <- maketensor(NT, MT)
      DP <- maketensor(NT, NT)

      # the following are like the matrices A to G in the Latex File
      # multiply with KZ3 accounts for the terms (1 - delta_{ij}) etc.
      A_ <- tensor::tensor(M, AP, 2, 1) * KZ3
      B_ <- tensor::tensor(M, BP, 2, 1) * KZ3
      C_ <- tensor::tensor(M, CP, 2, 1) * KZ3
      D_ <- tensor::tensor(M, DP, 2, 1) * KZ3
      E_ <- tensor::tensor(N, AP, 2, 1) * KZ3
      F_ <- tensor::tensor(N, BP, 2, 1) * KZ3
      G_ <- tensor::tensor(N, CP, 2, 1) * KZ3

      ####################

      lp[,47] <- 0.5 * large_tensor(DP, A_ * D_ - A_, edges)
      lp[,48] <- 0.5 * large_tensor(AP, G_ * (G_ - JZ3), edges)
      lp[,49] <- 0.25 * large_tensor(AP, D_ * (D_ - JZ3), edges)
      lp[,50] <- large_tensor(BP, D_ * C_, edges)
      lp[,51] <- large_tensor(BP, E_ * F_, edges)
      lp[,52] <- 0.5 * large_tensor(DP, B_ * C_, edges)
      lp[,53] <- large_tensor(AP, D_ * G_, edges)
      lp[,54] <- 0.5 * large_tensor(AP, F_ * G_, edges)
      lp[,55] <- large_tensor(DP, A_ * G_, edges)
      lp[,56] <- large_tensor(DP, B_ * E_, edges)
      lp[,57] <- large_tensor(BP, E_ * G_, edges)
      lp[,58] <- large_tensor(BP, C_ * G_, edges)
      lp[,59] <- large_tensor(BP, D_ * E_, edges)
      lp[,60] <- large_tensor(BP, C_ * F_, edges)
      lp[,61] <- large_tensor(DP, A_ * B_, edges)
      lp[,62] <- large_tensor(CP, A_ * G_, edges)
      lp[,63] <- large_tensor(BP, A_ * D_, edges)
      lp[,64] <- large_tensor(AP, C_ * G_, edges)
      lp[,65] <- large_tensor(AP, B_ * D_, edges)
      lp[,66] <- large_tensor(AP, E_ * G_, edges)
      lp[,67] <- 0.5 * large_tensor(DP, A_ * E_, edges)
      lp[,68] <- large_tensor(BP, A_ * G_, edges)
      lp[,69] <- 0.5 * large_tensor(AP, D_ * E_, edges)
      lp[,70] <- large_tensor(AP, C_ * F_, edges)
      lp[,71] <- 0.25 * large_tensor(DP, A_ * (A_ - JZ3), edges)
      lp[,72] <- large_tensor(AP, (A_ - JZ3) * F_, edges)
      lp[,73] <- 0.5 * large_tensor(AP, (A_ - JZ3) * D_, edges)
      lp[,74] <- 0.5 * large_tensor(BP, E_ * (E_ - JZ3), edges)
      lp[,75] <- 0.5 * large_tensor(BP, C_ * (C_ - JZ3), edges)
      lp[,76] <- large_tensor(BP, (B_ - JZ3) * E_, edges)
      lp[,77] <- large_tensor(BP, (B_ - JZ3) * C_, edges)
      lp[,78] <- large_tensor(BP, A_ * (B_ - JZ3), edges)
      lp[,79] <- 0.25 * large_tensor(AP, E_ * (E_ - JZ3), edges)
      lp[,80] <- 0.5 * large_tensor(AP, B_ * (B_ - JZ3), edges)
      lp[,81] <- large_tensor(BP, C_ * E_, edges)
      lp[,82] <- large_tensor(BP, A_ * E_, edges)
      lp[,83] <- large_tensor(BP, A_ * C_, edges)
      lp[,84] <- large_tensor(AP, B_ * E_, edges)
      lp[,85] <- 0.5 * large_tensor(AP, B_ * C_, edges)
      lp[,86] <- 0.5 * large_tensor(BP, A_ * (A_ - JZ3), edges)
      lp[,87] <- 0.5 * large_tensor(AP, (A_ - JZ3) * E_, edges)
      lp[,88] <- large_tensor(AP, (A_ - JZ3) * B_, edges)
      lp[,89] <- 0.25 * large_tensor(AP, (A_ - JZ3) * (A_ - 2*JZ3) * KZ3, edges)

    }
    if (NP < NZ) { # NP <= NZ
      JP3 <- array(rep(1, NP * NP * NP), c(NP, NP, NP)) # P x P x P array of ones
      KP3 <- JP3 # P x P x P matrix, 0 if two indices are equal, 1 otherwise
      for (i in 1 : NP){
        for (j in 1 : NP){
          KP3[i,j,j] <- 0
          KP3[j,i,j] <- 0
          KP3[j,j,i] <- 0
        }
      }

      ####
      # those are needed if z > p
      AZ <- maketensor(M, M)
      BZ <- maketensor(M, N)
      CZ <- maketensor(N, M)
      DZ <- maketensor(N, N)

      # the following are like the matrices A' to G' in the Latex File
      # multiply with KP3 accounts for the terms (1 - delta_{ij}) etc.
      A_2 <- tensor::tensor(M, AZ, 1, 1) * KP3
      B_2 <- tensor::tensor(M, BZ, 1, 1) * KP3
      C_2 <- tensor::tensor(M, CZ, 1, 1) * KP3
      D_2 <- tensor::tensor(M, DZ, 1, 1) * KP3
      E_2 <- tensor::tensor(N, AZ, 1, 1) * KP3
      F_2 <- tensor::tensor(N, BZ, 1, 1) * KP3
      G_2 <- tensor::tensor(N, CZ, 1, 1) * KP3

      ####
      lp[,47] <- 0.5 * large_tensor(F_2 * (F_2 - JP3), AZ, edges)
      lp[,48] <- 0.5 * large_tensor(A_2 * (D_2 - JP3), DZ, edges)
      lp[,49] <- 0.25 * large_tensor(D_2 * (D_2 - JP3), AZ, edges)
      lp[,50] <- large_tensor(D_2 * G_2, AZ, edges)
      lp[,51] <- large_tensor(A_2 * G_2, DZ, edges)
      lp[,52] <- 0.5 * large_tensor(F_2 * G_2, AZ, edges)
      lp[,53] <- large_tensor(C_2 * D_2, BZ, edges)
      lp[,54] <- 0.5 * large_tensor(B_2 * C_2, DZ, edges)
      lp[,55] <- large_tensor(E_2 * F_2, BZ, edges)
      lp[,56] <- large_tensor(E_2 * G_2, BZ, edges)
      lp[,57] <- large_tensor(B_2 * E_2, DZ, edges)
      lp[,58] <- large_tensor(D_2 * E_2, BZ, edges)
      lp[,59] <- large_tensor(C_2 * G_2, BZ, edges)
      lp[,60] <- large_tensor(C_2 * F_2, BZ, edges)
      lp[,61] <- large_tensor(E_2 * G_2, AZ, edges)
      lp[,62] <- large_tensor(A_2 * F_2, BZ, edges)
      lp[,63] <- large_tensor(C_2 * G_2, AZ, edges)
      lp[,64] <- large_tensor(A_2 * D_2, BZ, edges)
      lp[,65] <- large_tensor(B_2 * D_2, AZ, edges)
      lp[,66] <- large_tensor(A_2 * B_2, DZ, edges)
      lp[,67] <- 0.5 * large_tensor(E_2 * (E_2 - JP3), BZ, edges)
      lp[,68] <- large_tensor((B_2 - JP3) * E_2, BZ, edges)
      lp[,69] <- 0.5 * large_tensor(C_2 * (C_2 - JP3), BZ, edges)
      lp[,70] <- large_tensor(B_2 * (C_2 - JP3), CZ, edges)
      lp[,71] <- 0.25* large_tensor(E_2 * (E_2 - JP3), AZ, edges)
      lp[,72] <- large_tensor(A_2 * (C_2 - JP3), CZ, edges)
      lp[,73] <- 0.5 * large_tensor(C_2 * (C_2 - JP3), AZ, edges)
      lp[,74] <- 0.5 * large_tensor(A_2 * E_2, DZ, edges)
      lp[,75] <- 0.5 * large_tensor(D_2 * E_2, AZ, edges)
      lp[,76] <- large_tensor(A_2 * G_2, BZ, edges)
      lp[,77] <- large_tensor(B_2 * G_2, AZ, edges)
      lp[,78] <- large_tensor((A_2 - JP3) * G_2, AZ, edges)
      lp[,79] <- 0.25 * large_tensor(A_2* (A_2 - JP3), DZ, edges)
      lp[,80] <- 0.5 * large_tensor((A_2 - JP3) * D_2, AZ, edges)
      lp[,81] <- large_tensor(C_2 * E_2, BZ, edges)
      lp[,82] <- large_tensor(A_2 * E_2, BZ, edges)
      lp[,83] <- large_tensor(B_2 * E_2, AZ, edges)
      lp[,84] <- large_tensor(A_2 * C_2, BZ, edges)
      lp[,85] <- 0.5 * large_tensor(B_2 * C_2, AZ, edges)
      lp[,86] <- 0.5 * large_tensor((A_2 - JP3) * E_2, AZ, edges)
      lp[,87] <- 0.5 * large_tensor(A_2 * (A_2 - JP3), BZ, edges)
      lp[,88] <- large_tensor((A_2 - JP3) * C_2, AZ, edges)
      lp[,89] <- 0.25 * large_tensor((A_2 - JP3) * (A_2 - 2*JP3) * KP3, AZ, edges)
    }
  }

  #######################
  # now clean rows where the edge is not present
  lp <- subset(lp, lp[,1] == 1)

  # --------------- CONSIDER WEIGHTS -------------------------------------
  if (weights) {
    for (k in 1:nrow(lp)) {
      lp[k,] <- lp[k,] * edges[k,4]
    }
  }

  # --------------- NORMALISE --------------------------------------------

  if (normalisation == "none") {
    return(as.data.frame(lp))
  } else {
    norm_lp <- normalise_link_positions(lp, type = normalisation, six_node = six_node)
    return(as.data.frame(norm_lp))
  }

}