R/prepare_inputStparm.R

In Certara.Xpose.NLME: Enhances 'xpose' Diagnostics for Pharmacometric Models from 'Certara.RsNLME' and Phoenix NLME

prepare_inputStparm <-
  function(input,
           stparm,
           IDcol,
           TimeBased,
           CovModelNames) {
    if (nrow(input) == nrow(stparm)) {
      stparm <- .prepare_IDs(stparm, IDcol)

      stparm[, c("TableSource")] <- NULL

      if (TimeBased) {
        # removing input covariates and paste them from posthoc
        if (length(CovModelNames) > 0) {
          input <-
            subset(input,
                   select = setdiff(colnames(input), CovModelNames))
        }

        # need to figure out if some reset block is started with not 0 time point
        input_byID_WhichReset <-
          dplyr::group_by(input, ID, WhichReset)
        inputResetTime <-
          dplyr::filter(input_byID_WhichReset,
                        dplyr::row_number() == 1 & WhichReset != 0)

        if (any(inputResetTime$TIME > 0)) {
          # Reset blocks start not with 0 time
          # since Reset means that the data is not sorted, just replace the time
          message(
            "Reset blocks identified where the time of reset != 0. These blocks will use actual time."
          )
          stparm$time <- input$TIME
        }

        inputStparm <- dplyr::left_join(
          input,
          stparm,
          by = c("ID", "TIME" = "time"),
          suffix = c("_input", "")
        )
      } else {
        # split by ID; we cannot merge since the ID is not unique over rows
        stparmWoID <-
          subset(stparm, select = setdiff(colnames(stparm), "ID"))
        stparmSplitted <-
          base::split.data.frame(stparmWoID, stparm$ID)
        # rename the columns with the same names
        inputDupNames <-
          intersect(colnames(input), colnames(stparmWoID))
        if (length(inputDupNames) > 0) {
          inputNewNames <- paste0(inputDupNames, "_input")
          inputDFDupNames <- stats::setNames(
            colnames(input),
            replace(
              colnames(input),
              colnames(input) %in% inputDupNames,
              inputNewNames
            )
          )
          inputDFWODupNames <-
            dplyr::rename(input,!!!inputDFDupNames)
        } else {
          inputDFWODupNames <- input
        }

        inputSplitted <-
          base::split.data.frame(inputDFWODupNames, input$ID)

        keys <- unique(c(names(inputSplitted), names(stparmSplitted)))
        inputStparmListSplitted <-
          purrr::map2(inputSplitted[keys], stparmSplitted[keys], dplyr::bind_cols)
        inputStparm <-
          do.call(rbind.data.frame, inputStparmListSplitted)
      }
    } else {
      # for backward compatibility retain old join method
      if (TimeBased) {
        # not used for binding/merging
        stparm$time <- NULL
      }

      names(stparm)[1] <- "ID"

      inputStparm <- dplyr::left_join(input,
                                      stparm,
                                      by = "ID",
                                      suffix = c("_input", ""))
    }

    if (TimeBased) {
      stnames <- setdiff(colnames(stparm), c("time", "ID", CovModelNames))
    } else {
      stnames <- setdiff(colnames(stparm), c("ID", CovModelNames))
    }

    list(stparm = stparm,
         inputStparm = inputStparm,
         stnames = stnames)
  }

.prepare_IDs <- function(DF, IDcol) {
  # previous NLME8 version produced not renamed IDs
  IDs <- c("ID1", "ID2", "ID3", "ID4", "ID5")
  DFColNames <- colnames(DF)
  if (length(na.omit(match(IDs, DFColNames))) != 5) {
    IDs <- IDcol
    # this is special case whe ID is used in the input data
    # we are storing original ID in different column
    IDs[IDs == "ID_inputSortColumn"]  <- "ID"
  }

  if (length(IDcol) > 1) {
    # replacing IDs with concatenated ID; note that there are 5 ids
    # for the newly generated posthocs
    rowsList <-
      purrr::transpose(unname(purrr::map(DF[, IDs], as.character)))
    DF$ID <-
      purrr::map_chr(rowsList, function(x) {
        paste0(x[!is.na(x) & x != ""], collapse = "_")
      })
  } else {
    DF$ID <- as.character(unlist(DF[, IDs[length(IDs)]]))
  }

  DF[, c(IDs[IDs != "ID"])] <- NULL

  DF
}