inst/app/server/optimisation/optimise.R

In jackolney/CascadeDashboard: A Shiny App for Investigating The Current Trajectory of HIV Care

RunOptimisation <- function(propRuns = 0.1) {
    # This should be triggered by the renderPlot().
    withProgress(min = 0, max = 1, style = 'old', {

        # Simulation Loop
        time <- proc.time()[[1]]

        setProgress(value = 0, message = 'Starting optimisation', detail = 'creating parameter matrix')

        # Extract the initial values of a random 10% of simulations from calibration
        bestTenPercentCalibInitial <<- GetRandomTenPercentCalibOut(CalibOut = CalibOut, runError = runError, selectedRuns = selectedRuns, propRuns = propRuns)

        print(paste("reactiveAdjustCost$switch =", reactiveAdjustCost$switch))
        # Account for testing HIV-negatives
        AdjustHIVTestCost()

        # index counter
        iC <- 1L

        # output vectors
        rFirst90  <- c()
        rSecond90 <- c()
        rThird90  <- c()
        rVS       <- c()
        rImpact   <- c()
        rCost     <- c()
        rRho      <- c()
        rQ        <- c()
        rKappa    <- c()
        rGamma    <- c()
        rSigma    <- c()
        rOmega    <- c()
        rTest     <- c()
        rLink     <- c()
        rPreR     <- c()
        rInit     <- c()
        rAdhr     <- c()
        rRetn     <- c()

        # additional cost vectors
        rCostOrg <- c()
        rCostTot  <- c()

        # baseline trackers
        bTest     <- c()
        bLink     <- c()
        bPreR     <- c()
        bInit     <- c()
        bAdhr     <- c()
        bRetn     <- c()

        updateButton(session,
            inputId = "optimStart",
            label = "",
            style = "primary",
            block = TRUE,
            size = "large",
            icon = icon("refresh", class = "fa-lg fa-spin", lib = "font-awesome"))

        # because seven indicators
        for (j in 1:(dim(bestTenPercentCalibInitial)[1] / 7)) {

            message(paste('Simulation', j))

            # Run Baseline simulation
            BaseModel <- CallBaselineModel(runNumber = shuffledRuns[j], initVals = bestTenPercentCalibInitial[1:7 + 7 * (j - 1),])
            BaseDALY  <- Calc_DALY(BaseModel)
            BaseCost  <- Calc_Cost(BaseModel)
            rCostOrg[j] <- BaseCost
            message(paste("\t", scales::comma(BaseDALY), "DALYs, at", scales::dollar(BaseCost)))

            # Need some functions to calculate the BASELINE changes to care.
            bTest[j] <- BaseModel$CumDiag[251]
            bLink[j] <- BaseModel$CumLink[251]
            bPreR[j] <- BaseModel$CumPreL[251]
            bInit[j] <- BaseModel$CumInit[251]
            bAdhr[j] <- BaseModel$CumAdhr[251]
            bRetn[j] <- BaseModel$CumLoss[251]

            parSteps <- GetParaMatrixRun(cParamOut = CalibParamOut, runNumber = shuffledRuns[j], length = 2)

            for (i in 1:dim(parSteps)[1]) {
                cat("=")

                setProgress(
                    value = iC / ((dim(bestTenPercentCalibInitial)[1] / 7) * dim(parSteps)[1]),
                    message = paste('Simulation', j),
                    detail = paste('Run', i))

                # This need modifying
                p <- GetOptRunPar(
                    masterCD4 = MasterData$cd4_2015,
                    data = MasterData,
                    iterationParam = parSteps[i,],
                    calibParamOut = CalibParamOut,
                    runNumber = shuffledRuns[j])

                # Now we need the initials.
                y <- GetInitial(
                    p = p,
                    iterationResult = bestTenPercentCalibInitial[1:7 + 7 * (j - 1),],
                    masterCD4 = MasterData$cd4_2015)

                p[["beta"]] <- GetBeta(y = y, p = p, iterationInc = CalibIncOut[shuffledRuns[j],])

                SimResult <- RunSim_Prop(y = y, p = p)

                # These guys keep going
                rFirst90[iC]  <- Calc_909090_Result(  SimResult )[1]
                rSecond90[iC] <- Calc_909090_Result(  SimResult )[2]
                rThird90[iC]  <- Calc_909090_Result(  SimResult )[3]
                rVS[iC]       <- Calc_VS(             SimResult )
                rImpact[iC]   <- Calc_DALYsAverted(   SimResult , BaseDALY)
                rCost[iC]     <- Calc_AdditionalCost( SimResult , BaseCost)
                rCostTot[iC]  <- Calc_Cost(SimResult)

                # Care Calculations
                rTest[iC]     <- Calc_CareTesting(baseResult      = BaseModel, simResult = SimResult)
                rLink[iC]     <- Calc_CareLinkage(baseResult      = BaseModel, simResult = SimResult)
                rPreR[iC]     <- Calc_CarePreRetention(baseResult = BaseModel, simResult = SimResult)
                rInit[iC]     <- Calc_CareInitiation(baseResult   = BaseModel, simResult = SimResult)
                rAdhr[iC]     <- Calc_CareAdherence(baseResult    = BaseModel, simResult = SimResult)
                rRetn[iC]     <- Calc_CareRetention(baseResult    = BaseModel, simResult = SimResult)

                # These should always just reference i in all cases (as they repeat)
                rRho[iC]    <- parSteps[i,"Rho"]
                rQ[iC]      <- parSteps[i,"Q"]
                rKappa[iC]  <- parSteps[i,"Kappa"]
                rGamma[iC]  <- parSteps[i,"Gamma"]
                rSigma[iC]  <- parSteps[i,"Sigma"]
                rOmega[iC]  <- parSteps[i,"Omega"]

                iC <- iC + 1L
            }
            cat("\n")
        }

        optResults <<- data.frame(rFirst90, rSecond90, rThird90, rVS, rCost, rRho, rQ, rKappa, rGamma, rSigma, rOmega, rTest, rLink, rPreR, rInit, rAdhr, rRetn, rCostTot)
        colnames(optResults) <<- c("First 90", "Second 90", "Third 90", "VS", "Cost", "Rho", "Q", "Kappa", "Gamma", "Sigma", "Omega", "Testing", "Linkage", "Pre-ART Retention", "Initiation", "Adherence", "ART Retention", "Total Cost")

        # Make all the baseline stuff global
        BaselineCost <<- rCostOrg
        BaselineTest <<- bTest
        BaselineLink <<- bLink
        BaselinePreR <<- bPreR
        BaselineInit <<- bInit
        BaselineAdhr <<- bAdhr
        BaselineRetn <<- bRetn

        setProgress(value = 1, message = "Finished", detail = paste(round(proc.time()[[1]] - time, 0), "seconds"))

        updateButton(session,
            inputId = "optimStart",
            label = "Start",
            style = "success",
            block = TRUE,
            size = "large",
            icon = icon("play", class = "fa-lg fa-fw", lib = "font-awesome"))
    })
    optResults
}