#' Hierarchical piecewise linear model / piecewise regression for multiple cases
#'
#' The [hplm()] function computes a hierarchical piecewise regression model. It
#' extends the standard piecewise regression model to multiple cases by
#' estimating fixed and random effects. The function uses the `lme` function of
#' the `nlme` package to fit linear mixed-effects models. The model can include
#' random intercepts and random slopes for level, trend, and treatment effects.
#' Additionally, it allows for the inclusion of autoregressive structures and
#' unequal variances across phases. The function also provides options for
#' likelihood ratio tests to compare models with and without random slope
#' effects, as well as the calculation of intraclass correlations (ICC) to
#' assess the proportion of variance attributable to between-case differences.
#' This function is particularly useful for analyzing data from multiple
#' single-case experimental designs (SCEDs) where observations are nested within
#' cases.
#'
#' @section Model specification: The fixed effects part of the model can be
#'   specified using the `fixed` argument, while the random effects part can be
#'   specified using the `random` argument. If not provided, default formulas
#'   based on the specified model type (e.g., "B&L-B") are created. The function
#'   also allows for the inclusion of autoregressive structures through the `ar`
#'   argument and unequal variances across phases through the
#'   `unequal_variances` argument.
#' @section Random slopes: By setting the `random.slopes` argument to TRUE, the
#'   model will include random slope effects for level, trend, and treatment
#'   effects. This allows for individual differences in how cases respond to
#'   these effects.
#' @section Likelihood ratio tests: If the `lr.test` argument is set to TRUE,
#'   the function will perform likelihood ratio tests to compare models with and
#'   without random slope effects. This helps to determine whether including
#'   random slopes significantly improves model fit.
#' @section Intraclass correlation: If the `ICC` argument is set to TRUE, the
#'   function will calculate the intraclass correlation coefficient (ICC) to
#'   assess the proportion of variance attributable to between-case differences.
#'   This provides insight into the degree of similarity among observations
#'   within the same case.
#'
#' @inheritParams .inheritParams
#' @order 1
#' @param method Method used to fit your model. Pass `"REML"` to maximize the
#'   restricted log-likelihood or `"ML"` for maximized log-likelihood. Default
#'   is `"ML"`.
#' @param control A list of settings for the estimation algorithm, replacing the
#'   default values passed to the function `lmeControl` of the `nlme` package.
#' @param random.slopes If `random.slopes = TRUE` random slope effects of the
#'   level, trend, and treatment parameter are estimated.
#' @param lr.test If set TRUE likelihood ratio tests are calculated comparing
#'   model with vs. without random slope parameters.
#' @param ICC If `ICC = TRUE` an intraclass-correlation is estimated.
#' @param random_trend If TRUE, includes a random trend trend effect.
#' @param random_level If TRUE, includes a random level trend effect.
#' @param random_slope If TRUE, includes a random slope trend effect.
#' @param fixed Defaults to the fixed part of the standard piecewise regression
#'   model. The parameter phase followed by the phase name (e.g., phaseB)
#'   indicates the level effect of the corresponding phase. The parameter
#'   'inter' followed by the phase name (e.g., interB) adresses the slope effect
#'   based on the method provide in the model argument (e.g., "B&L-B"). The
#'   formula can be changed for example to include further L1 or L2 variables
#'   into the regression model.
#' @param random The random part of the model. Defaults to a random intercept
#'   model. The formula can be changed to include random slope effects for
#'   level, trend, and treatment effects.
#' @param ar Maximal lag of autoregression. Modelled based on the
#'   Autoregressive-Moving Average (ARMA) function.
#' @param unequal_variances Logical. If set TRUE, estimations are weighted by
#'   phase variances.
#' @param update.fixed An easier way to change the fixed model part (e.g., `. ~
#'   . + newvariable`).
#' @param data.l2 A data frame providing additional variables at Level 2. The
#'   scdf File has to have names for all cases and the Level 2 data frame has to
#'   have a column named 'cases' with the names of the cases the Level 2
#'   variables belong to.
#' @param ... Further arguments passed to the lme function.
#' @return An object of class `sc_hplm`.
#' - `model` | List containing infromation about
#' - `N` | Number of single-cases. 
#' - `formula` | A list containing the fixed and the random formulas of the hplm model.
#' - `hplm` | Object of class lme contaning the multilevel model. 
#' - `model.0` | Object of class lme containing the zero model. 
#' - `ICC` | List containing intraclass correlation and test parameters. 
#' - `model.without` | Object of class gls containing the fixed effect model. 
#' - `contrast` | List with contrast definitions.
#' @author Juergen Wilbert
#' @family regression functions
#' @examples
#'
#' ## Compute hplm model on a MBD over fifty cases (restricted log-likelihood)
#' hplm(exampleAB_50, method = "REML", random.slopes = FALSE)
#'
#' ## Analyzing with additional L2 variables
#' Leidig2018 |>
#'   add_l2(Leidig2018_l2) |>
#'   hplm(update.fixed = .~. + gender + migration + ITRF_TOTAL*phaseB,
#'        slope = FALSE, random.slopes = FALSE, lr.test = FALSE
#'   )
#'
#' @export

hplm <- function(data, dvar, pvar, mvar, 
                 model = c("W", "H-M", "B&L-B", "JW"),
                 contrast = c("first", "preceding"),
                 contrast_level = NA,
                 contrast_slope = NA,
                 method = c("ML", "REML"), 
                 control = list(opt = "optim"), 
                 random.slopes = FALSE, 
                 lr.test = FALSE, 
                 ICC = TRUE, 
                 trend = TRUE, 
                 level = TRUE, 
                 slope = TRUE, 
                 random_trend = FALSE, 
                 random_level = FALSE, 
                 random_slope = FALSE, 
                 fixed = NULL, 
                 random = NULL, 
                 ar = 0,
                 unequal_variances = FALSE,
                 update.fixed = NULL, 
                 data.l2 = NULL, 
                 ...) {

  args_add <- list(...)
  
  check_args(
    by_call(model),
    by_call(method),
    by_call(contrast),
    not(ar > 0 && "correlation" %in% names(args_add), 
        "ar and correlation arguments defined at the same time."
    ),
    not(unequal_variances && "weights" %in% names(args_add), 
        "unequal_variances and weights arguments defined at the same time."
    )
  )
  
  if (model == "JW") {
    contrast_level <- "preceding"
    contrast_slope <- "preceding"
    model <- "B&L-B"
  }
  
  if (is.na(contrast_level)) contrast_level <- contrast
  if (is.na(contrast_slope)) contrast_slope <- contrast

  if (random.slopes) {
    random_trend <- trend
    random_level <- level
    random_slope <- slope
  }
  
  # set attributes to arguments else set to defaults of scdf
  if (missing(dvar)) dvar <- dv(data) else dv(data) <- dvar
  if (missing(pvar)) pvar <- phase(data) else phase(data) <- pvar
  if (missing(mvar)) mvar <- mt(data) else mt(data) <- mvar
  
  dat <- .prepare_scdf(data)
  
  N <- length(dat)
  out <- list()
  out$model$interaction.method  <- model
  out$model$contrast.method     <- contrast
  out$model$estimation.method   <- method
  out$model$lr.test             <- lr.test
  out$model$random.slopes       <- random.slopes
  out$model$ICC                 <- ICC
  out$N                         <- N

# interaction and dummy coding and L2 --------------------------------------

  tmp_model <- .add_dummy_variables(
    data = dat, model = model, 
    contrast_level = contrast_level, contrast_slope = contrast_slope
  )
  
  dat <- tmp_model$data

  dat <- as.data.frame(dat, l2 = data.l2)

# create formulas ---------------------------------------------------------

  if (is.null(fixed)) {
    fixed <- .create_fixed_formula(
      dvar, mvar, slope, level, trend, tmp_model$var_phase, tmp_model$var_inter
    )
  }
  if (!is.null(update.fixed)) fixed <- update(fixed, update.fixed)
  
  
  if (any(random_trend, random_level, random_slope)) {
    random.slopes <- TRUE
  }
  
  if (!random.slopes && is.null(random)) 
    random <- as.formula("~1|case")
  
  if (is.null(random)) {
    random <- .create_random_formula(
      mvar, 
      random_slope, random_level, random_trend, 
      tmp_model$var_phase, 
      tmp_model$var_inter
    )
  }
  out$formula <- list(fixed = fixed, random = random)

  if (ar > 0) {
    args_add$correlation <- corARMA(
      form = as.formula(paste0("~", mvar, " | case")), 
      p = ar, q = 0
    )
  }
  
  if (unequal_variances) {
    args_add$weights <- varIdent(form = as.formula(paste0("~ 1 | ", pvar)))
  }
  
  args <- list(
    fixed = fixed,
    random = random,
    data = dat,
    na.action = na.omit,
    method = method,
    control = control,
    keep.data = FALSE
  )
  args <- c(args, args_add)
 
# lme hplm model ----------------------------------------------------------
  out$hplm <- do.call(lme, args) 
  
  # check:
  #out$hplm <- lme(
  #  fixed = fixed,
  #  random = random,
  #  data = dat,
  #  na.action = na.omit,
  #  method = method,
  #  control = control,
  #  keep.data = FALSE,
  #  ...
  #)

  out$hplm$call$fixed <- fixed
  out$hplm$call$random <- random
  out$hplm$call$data <- str2lang("dat")
  
# LR tests ----------------------------------------------------------------

  if (lr.test) {
    pred_rand    <- unlist(strsplit(as.character(random[2]), "\\|"))[1]
    pred_rand_id <- unlist(strsplit(as.character(random[2]), "\\|"))[2]
    pred_rand    <- unlist(strsplit(pred_rand, "\\+"))
    pred_rand    <- trimws(pred_rand)
    pred_rand_id <- trimws(pred_rand_id)

    if (length(pred_rand) == 1) {
      abort("LR Test not applicable with only one random effect.")
    }
    
    random_ir <- list(formula(gsub("1", "-1", paste(random, collapse = " "))))
    for(i in 2:length(pred_rand)) {
      random_ir[[i]] <- formula(
        paste0("~", paste0(pred_rand[!pred_rand %in% pred_rand[i]], 
        collapse = " + "), " | ", pred_rand_id)
      )
    }
    out$random_ir$restricted <- list()
    
    # lme
    for(i in 1:length(random_ir)) {
      
      args_restricted <- args
      args_restricted$random <- random_ir[i]
      
      out$random_ir$restricted[[i]] <- do.call(lme, args_restricted)
      out$random_ir$restricted[[i]]$call$data <- str2lang("dat")
      # check:
      # out$random_ir$restricted[[i]] <- lme(
      #   fixed = fixed, 
      #   random = random_ir[i], 
      #   data = dat,
      #   na.action = na.omit, 
      #   method = method, 
      #   control=control,
      #   keep.data = FALSE, 
      #   ...
      # )
      out$random_ir$restricted[[i]]$call$data <- str2lang("dat")
      out$random_ir$restricted[[i]]$call$fixed <- fixed
    }
    out$LR.test <- list()
    
    # LR test
    for(i in 1:length(random_ir)) {
      out$LR.test[[i]] <- anova(out$random_ir$restricted[[i]], out$hplm)
    }
    attr(out$random_ir, "parameters") <- c("Intercept", pred_rand)
  }
  
# ICC ---------
  
  if (ICC) {
    .formula.null <- as.formula(paste0(dvar, " ~ 1"))
    out$model.0 <- lme(
      .formula.null, random =~1|case, data = dat, 
      method = method, na.action = na.omit, control = control
    )
    out$model.0$call$fixed <- .formula.null
    
    vc <- as.numeric(VarCorr(out$model.0))
    out$ICC$value <- vc[1] / (vc[1] + vc[2])	
    out$model.without <- gls(
      .formula.null, data = dat, method = method, 
      na.action = na.omit, control = control
    )
    out$model.without$call$model <- .formula.null
    dif <- anova(out$model.0, out$model.without)
    out$ICC$L <- dif$L.Ratio[2]
    out$ICC$p <- dif$"p-value"[2]
  } 
  
# out ---
  
  out$model$fixed  <- fixed
  out$model$random <- random
  out$model$ar <- ar
  out$model$unequal_variances <- unequal_variances
  out$contrast <- list(level = contrast_level, slope = contrast_slope)
  
  class(out) <- c("sc_hplm")
  attributes(out)[opts("phase", "mt", "dv")] <- list(pvar, mvar, dvar)
  out
}

