R/funcs_optim-objectives.R

In cath-parkinson/mm.reoptimise: Run and Compare Budget Optimisation in Different Scenarios

# Objective Function and Gradient
optim_alloc <- function(x, constant, curve_equations,
                        p1, p2, p3, p4, p5, p6, p7, p8, p9){
      # au: allocation unit
      # r: response
      # g: gradient

      # number of allocation units
      n_au <- length(x)

      # one value per allocation unit
      # sum of the uplift computed for each curve of the allocation unit
      # for the same value of x (spend)
      r_vector <- vector("numeric", n_au)
      g_vector <- vector("numeric", n_au)

      # for each allocation unit
      for (i in 1:n_au) {

            # get parameters from list column
            au_curves_equations <- curve_equations[[i]] %>% unlist() %>% unname()
            au_p1 <- p1[[i]] %>% unlist() %>% unname() %>% `*`(constant)
            au_p2 <- p2[[i]] %>% unlist() %>% unname() %>% `*`(constant)
            au_p3 <- p3[[i]] %>% unlist() %>% unname() %>% `*`(constant)
            au_p4 <- p4[[i]] %>% unlist() %>% unname() %>% `*`(constant)
            au_p5 <- p4[[i]] %>% unlist() %>% unname() %>% `*`(constant)
            au_p6 <- p4[[i]] %>% unlist() %>% unname() %>% `*`(constant)
            au_p7 <- p4[[i]] %>% unlist() %>% unname() %>% `*`(constant)
            au_p8 <- p4[[i]] %>% unlist() %>% unname() %>% `*`(constant)
            au_p9 <- p4[[i]] %>% unlist() %>% unname() %>% `*`(constant)

            # number of curves in allocation unit
            n_curves_au_i <- length(au_p1)

            # one value per curve in allocation unit
            r_vector_au_i <- vector("numeric", n_curves_au_i)
            g_vector_au_i <- vector("numeric", n_curves_au_i)

            # for each curve
            # we always optimise over net curves
            for (j in 1:n_curves_au_i){
                  if (au_curves_equations[[j]] == "dim_rets"){
                        r_curve_j <- dimrets_function(x[[i]], au_p1[[j]], au_p2[[j]])
                        g_curve_j <- dimrets_gradient(x[[i]], au_p1[[j]], au_p2[[j]])
                  } else if (au_curves_equations[[j]] == "s_curve"){
                        r_curve_j <- s_curve_function(x[[i]], au_p1[[j]], au_p2[[j]], au_p3[[j]], au_p4[[j]])
                        g_curve_j <- s_curve_gradient(x[[i]], au_p1[[j]], au_p2[[j]], au_p3[[j]], au_p4[[j]])
                  } else if (au_curves_equations[[j]] == "linear"){
                        r_curve_j <- linear_function(x[[i]], au_p1[[j]])
                        g_curve_j <- linear_gradient(x[[i]], au_p1[[j]])
                  }
                  r_vector_au_i[[j]] <- r_curve_j
                  g_vector_au_i[[j]] <- g_curve_j
            }

            # return uplift for allocation unit by sum over each curve uplift
            r_vector[[i]] <- r_vector_au_i %>% sum()
            g_vector[[i]] <- g_vector_au_i %>% sum()
      }

      # get total uplift by sum over each allocation unit uplift
      r <- r_vector %>% sum()

      # return negative uplift to minimize function
      return(
            list(
                  "objective" = -r,
                  "gradient"  = g_vector
            )
      )
}


# Objective Function and Gradient
optim_alloc_pct <- function(x, constant, curve_equations,
                            p1, p2, p3, p4, p5, p6, p7, p8, p9){
      # au: allocation unit
      # r: response
      # g: gradient

      # number of allocation units
      n_au <- length(x)

      # one value per allocation unit
      # sum of the uplift computed for each curve of the allocation unit
      # for the same value of x (spend)
      r_vector <- vector("numeric", n_au)
      g_vector <- vector("numeric", n_au)

      # for each allocation unit
      for (i in 1:n_au) {

            # get parameters from list column
            au_curves_equations <- curve_equations[[i]] %>% unlist() %>% unname()
            au_p1 <- p1[[i]] %>% unlist() %>% unname()
            au_p2 <- p2[[i]] %>% unlist() %>% unname()
            au_p3 <- p3[[i]] %>% unlist() %>% unname()
            au_p4 <- p4[[i]] %>% unlist() %>% unname()
            au_p5 <- p4[[i]] %>% unlist() %>% unname()
            au_p6 <- p4[[i]] %>% unlist() %>% unname()
            au_p7 <- p4[[i]] %>% unlist() %>% unname()
            au_p8 <- p4[[i]] %>% unlist() %>% unname()
            au_p9 <- p4[[i]] %>% unlist() %>% unname()

            # number of curves in allocation unit
            n_curves_au_i <- length(au_p1)

            # one value per curve in allocation unit
            r_vector_au_i <- vector("numeric", n_curves_au_i)
            g_vector_au_i <- vector("numeric", n_curves_au_i)

            # for each curve
            # we always optimise over net curves
            for (j in 1:n_curves_au_i){
                  if (au_curves_equations[[j]] == "dim_rets"){
                        r_curve_j <- dimrets_function(x[[i]], au_p1[[j]], au_p2[[j]])
                        g_curve_j <- dimrets_gradient(x[[i]], au_p1[[j]], au_p2[[j]])
                  } else if (au_curves_equations[[j]] == "s_curve"){
                        r_curve_j <- s_curve_function(x[[i]], au_p1[[j]], au_p2[[j]], au_p3[[j]], au_p4[[j]])
                        g_curve_j <- s_curve_gradient(x[[i]], au_p1[[j]], au_p2[[j]], au_p3[[j]], au_p4[[j]])
                  } else if (au_curves_equations[[j]] == "linear"){
                        r_curve_j <- linear_function(x[[i]], au_p1[[j]])
                        g_curve_j <- linear_gradient(x[[i]], au_p1[[j]])
                  }
                  r_vector_au_i[[j]] <- constant * r_curve_j
                  g_vector_au_i[[j]] <- constant * g_curve_j
            }

            # return uplift for allocation unit by sum over each curve uplift
            r_vector[[i]] <- r_vector_au_i %>% sum()
            g_vector[[i]] <- g_vector_au_i %>% sum()
      }

      # get total uplift by sum over each allocation unit uplift
      r <- r_vector %>% sum()

      # return negative uplift to minimize function
      return(
            list(
                  "objective" = -r,
                  "gradient"  = g_vector
            )
      )
}




# Objective Function and Gradient
optim_alloc_net <- function(x, constant, curve_equations,
                        p1, p2, p3, p4, p5, p6, p7, p8, p9){
      # au: allocation unit
      # r: response
      # g: gradient

      # number of allocation units
      n_au <- length(x)

      # one value per allocation unit
      # sum of the uplift computed for each curve of the allocation unit
      # for the same value of x (spend)
      r_vector <- vector("numeric", n_au)
      g_vector <- vector("numeric", n_au)

      # for each allocation unit
      for (i in 1:n_au) {

            # get parameters from list column
            au_curves_equations <- curve_equations[[i]] %>% unlist() %>% unname()
            au_p1 <- p1[[i]] %>% unlist() %>% unname() %>% `*`(constant)
            au_p2 <- p2[[i]] %>% unlist() %>% unname() %>% `*`(constant)
            au_p3 <- p3[[i]] %>% unlist() %>% unname() %>% `*`(constant)
            au_p4 <- p4[[i]] %>% unlist() %>% unname() %>% `*`(constant)
            au_p5 <- p4[[i]] %>% unlist() %>% unname() %>% `*`(constant)
            au_p6 <- p4[[i]] %>% unlist() %>% unname() %>% `*`(constant)
            au_p7 <- p4[[i]] %>% unlist() %>% unname() %>% `*`(constant)
            au_p8 <- p4[[i]] %>% unlist() %>% unname() %>% `*`(constant)
            au_p9 <- p4[[i]] %>% unlist() %>% unname() %>% `*`(constant)

            # number of curves in allocation unit
            n_curves_au_i <- length(au_p1)

            # one value per curve in allocation unit
            r_vector_au_i <- vector("numeric", n_curves_au_i)
            g_vector_au_i <- vector("numeric", n_curves_au_i)

            # for each curve
            # we always optimise over net curves
            for (j in 1:n_curves_au_i){
                  if (au_curves_equations[[j]] == "dim_rets"){
                        r_curve_j <- net_dimrets_function(x[[i]], au_p1[[j]], au_p2[[j]])
                        g_curve_j <- net_dimrets_gradient(x[[i]], au_p1[[j]], au_p2[[j]])
                  } else if (au_curves_equations[[j]] == "s_curve"){
                        r_curve_j <- net_s_curve_function(x[[i]], au_p1[[j]], au_p2[[j]], au_p3[[j]], au_p4[[j]])
                        g_curve_j <- net_s_curve_gradient(x[[i]], au_p1[[j]], au_p2[[j]], au_p3[[j]], au_p4[[j]])
                  } else if (au_curves_equations[[j]] == "linear"){
                        r_curve_j <- net_linear_function(x[[i]], au_p1[[j]])
                        g_curve_j <- net_linear_gradient(x[[i]], au_p1[[j]])
                  }
                  r_vector_au_i[[j]] <- r_curve_j
                  g_vector_au_i[[j]] <- g_curve_j
            }

            # return uplift for allocation unit by sum over each curve uplift
            r_vector[[i]] <- r_vector_au_i %>% sum()
            g_vector[[i]] <- g_vector_au_i %>% sum()
      }

      # get total uplift by sum over each allocation unit uplift
      r <- r_vector %>% sum()

      # return negative uplift to minimize function
      return(
            list(
                  "objective" = -r,
                  "gradient"  = g_vector
            )
      )
}