R/prepare_inputStparmResid.R

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

prepare_inputStparmResid <-
  function(inputStparm, residuals, IDcol, TimeBased) {
    # figure out IDs in residuals
    residuals <- .prepare_IDs(residuals, IDcol)

    if (TimeBased) {
      residuals$TIME <- residuals$IVAR

      inpuStparmTIMEWONA <- inputStparm$TIME[!is.na(inputStparm$TIME)]
      if (any(inpuStparmTIMEWONA != signif(inpuStparmTIMEWONA)) &
          all(residuals$TIME == signif(residuals$TIME))) {
        warning(
          "Rounded TIME values are possible in residuals;",
          "\n residuals will be merged with the source data using rounded TIME column."
        )
        tempCol <- "ROUNDED_TIME_G6_MERGE"
        while (tempCol %in% colnames(inputStparm)) {
          # prevent changing any existing column
          tempCol <- paste0(tempCol, "_1")
        }
        inputStparm[tempCol] <- signif(inputStparm$TIME, 6)

        byVector <- stats::setNames(c("ID", "WhichReset", "TIME"),
                                    c("ID", "WhichReset", tempCol))

        d1 <- dplyr::full_join(inputStparm,
                               residuals,
                               by = byVector,
                               suffix = c("_input", ""))
        d1[tempCol] <- NULL
      } else {
        # need to figure out if some reset block is started with not 0 time point
        inputStparm_byID_WhichReset <-
          dplyr::group_by(inputStparm, ID, WhichReset)
        inputStparmResetTime <-
          dplyr::filter(inputStparm_byID_WhichReset,
                        dplyr::row_number() == 1 & WhichReset != 0)

        if (any(inputStparmResetTime$TIME > 0)) {
          # need to modify residuals
          inputStparmResetTime <-
            dplyr::select(inputStparmResetTime, ID, WhichReset, TIME)
          inputStparmResetTime <-
            dplyr::rename(inputStparmResetTime, RESETBLOCKTIMESTART = TIME)
          residuals <-
            dplyr::left_join(residuals,
                             inputStparmResetTime,
                             by = c("ID", "WhichReset"))
          residuals$TIME <-
            ifelse(
              is.na(residuals$RESETBLOCKTIMESTART),
              residuals$TIME,
              residuals$TIME + residuals$RESETBLOCKTIMESTART
            )
          residuals$IVAR <- residuals$TIME
          residuals$RESETBLOCKTIMESTART <- NULL
        }

        d1 <- dplyr::full_join(
          inputStparm,
          residuals,
          by = c("ID", "WhichReset", "TIME"),
          suffix = c("_input", "")
        )
      }
    } else {
      if (nrow(residuals) == nrow(inputStparm)) {
        # split by ID; we cannot merge since the ID is not unique over rows
        residualsSplitted <-
          base::split.data.frame(residuals, residuals$ID)
        # rename the columns with the same names
        inputStparmWoID <-
          subset(inputStparm, select = setdiff(
            colnames(inputStparm),
            c("ID", "WhichReset", "Scenario")
          ))
        inputStparmDupNames <-
          intersect(colnames(inputStparmWoID), colnames(residuals))
        if (length(inputStparmDupNames) > 0) {
          # there are duplicates to rename
          inputStparmNewNames <- paste0(inputStparmDupNames, "_input")
          inputStparmDFWODupNames <-
            stats::setNames(
              colnames(inputStparmWoID),
              replace(
                colnames(inputStparmWoID),
                colnames(inputStparmWoID) %in% inputStparmDupNames,
                inputStparmNewNames
              )
            )
          inputStparmDFWODupNames <-
            dplyr::rename(inputStparmWoID,!!!inputStparmWODupNames)
        } else {
          inputStparmDFWODupNames <- inputStparmWoID
        }

        inputStparmSplitted <-
          base::split.data.frame(inputStparmDFWODupNames, inputStparm$ID)

        keys <-
          unique(c(names(inputStparmSplitted), names(residualsSplitted)))
        inputStparmResListSplitted <-
          purrr::map2(inputStparmSplitted[keys],
                      residualsSplitted[keys],
                      dplyr::bind_cols)
        d1 <- do.call(rbind.data.frame, inputStparmResListSplitted)
      } else {
        d1 <- dplyr::full_join(
          inputStparm,
          residuals,
          by = c("ID", "WhichReset"),
          suffix = c("_input", "")
        )
      }
    }

    d1
  }