factor.qmd

---
title: "factors"
format: html
---


## factor documentation

time units:

-   pp   = prior period
-   cp   = current period
-   diff = difference between pp and cp

aggregate dimensions
-   sum  = sum the the value_var  
-   mean = take the simple row level average of the the value_var  
-   row  = keep the row level granularity without aggregating
-   wtdavg  = take the wtd. average of the value_var

## how will you use this?

```{r}

factor <- function(.data,formula,target){
  
  return("success")
  
}

data |>
  factor(
    volume~(cp(quantity,row)*pp(quantity_prop,row)-pp(quantity-row))*cp(net_price,row)
  ) |> 
  ## extract each argument one by one
  ## modify each to add data to it
  ## executive each to moditfy data an add column
  ## then store the new colum names and add another column with the name 
  ## how to deal with grups? add in a grouped frame
  
  
  
  factor(
    price ~ (cp(quantity,row)*pp(quantity_prop,row)-pp(quantity-row))*cp(net_price,row)
  ) |> 
  factor(
    mix ~ (cp(quantity,row)*pp(quantity_prop,row)-pp(quantity-row))*cp(net_price,row)
  ) |> 
  pvm(target=revenue,new_products=FALSE,discontinued_products=TRUE) 


data |> 
  mutate(
    volume=(lag_quantity*lag_quantity_prop)-(lag_quantity*net_price)
  ) 



      vol(vol     ~ pp(quantity,sum)          * d(price_realization) )+
    price(price   ~ d(quantity)           * cp(price_realization) )+
     mix1(mix1    ~ cp(quantity,sum))     * pp(mix)-cp(quantity))+
     mix2(mix2    ~ pp(price_realization) -  pp(price_realization,mean))+
      mix(mix     ~ mix1                  * mix2)


```

# lets create some sample data


```{r}
alternative_result <- 10

  if (!is.numeric(alternative_result)) {
    
  }

assertthat::assert_that(
  is.numeric("alternative_result")
  ,msg = eval(msg)
)


msg <- cli::cli_alert(text = "tihs is a test")

example_tbl <- function(class) {
  vctrs::new_data_frame(
    list(
      a = letters[1:3],
      b = data.frame(c = 1:3, d = 4:6 + 0.5)
    ),
    class = c(class, "tbl")
  )
}
library(tibble)
example_tbl("default")


tbl_sum.default_header_extend <- function(x, ...) {
  default_header <- NextMethod()
  c(default_header, "PVM" = "Summary of PVM mix with inputs how long can this go and util it stops doing this")
}


pillar:::print_tbl(example_tbl("default_header_extend"))
```






```{r}
library(tidyverse)
devtools::load_all()

db <- fpaR::create_contonso_duckdb()

sales_db <- db$sales

sales_tbl <- 
  fpaR::sales |>
  mutate(
    month=month(order_date)
  ) |>
  group_by(
    month
    ,product_key
  ) |>
  summarize(
    quantity=sum(quantity)
    ,net_price=sum(net_price)
    ,.groups="drop"
  ) |>
  group_by(month) |>
  arrange(product_key,.by_group = TRUE) |>
  ungroup() |>
  mutate(
    price_realization=net_price/quantity
    ,mix=net_price/sum(net_price)
    ,revenue=net_price*quantity
  ) |>
  filter(
    month %in% c(1,2)
  ) |> 
    select(
    month,product_key,quantity,net_price,revenue
  ) 


sales_tbl |> 

  pivot_wider(
    names_from = month
    ,values_from=quantity:revenue
  )
  

sales_slim_tbl <- sales_tbl |>
  group_by(month) |>
  mutate(
    total_revenue=sum(revenue)
    ,total_quantity=sum(quantity)
  ) |>
  group_by(product_key) |>
  mutate(
    lag_quantity=lag(quantity,1,NA)
    ,lag_revenue=lag(revenue,1,NA)
    ,lag_net_price=lag(net_price,1,NA)
    ,lag_total_revenue=lag(total_revenue,1,NA)
     ,lag_total_quantity=lag(total_quantity,1,NA)
    ,delta_quantity=quantity-lag_quantity
    ,delta_net_price=net_price-lag_net_price
    ,delta_revenue=revenue-lag_revenue
    ,mix=revenue/total_revenue
    ,lag_max=lag_revenue/lag_total_revenue
    ,quantity_prop=quantity/total_quantity
    ,lag_quantity_prop=lag_quantity/lag_total_quantity
  ) |>
  arrange(product_key) |>
  drop_na()


## factor analysis
sales_slim_tbl |> 
  group_by(month) |> 
  mutate(
    volume_effect=((quantity*lag_quantity_prop)-lag_quantity)*net_price
  ) |> 
  ungroup() |> 
  summarise(
    volume_effect=sum(volume_effect)
  )

  
```


vol=(cp(quantity,row)*pp(quantity_prop,row)-pp(quantity-row))*cp(net_price,row)

cp(quantity,row)=quantity
pp(quantity_prop,row)=lag_quantity_prop
cp(net_price,row)=net_price

cp=column_as_is
pp=lag_column_as_is
row=nothing

### Aproach 1

- just have outside functions return column names

```{r}

pp <- function(.data,column,fn="row"){
  

  #original column name
    
  column_name <- rlang::as_name(rlang::enquo(column))

  # Capture the column name and aggregation function
  column_name_adj <- paste0("lag_",column_name)
  

  if(fn=="row"){
    
  column_expr_adj <- column_name_adj
    
  }else{
    
  column_expr_adj <- rlang::quo_name(
    rlang::call2(fn, column_name_adj,na.rm=TRUE)
    )
  }
  
  
  
  if(is.null(attr(.data,"column_name"))){
    
    .data <- structure(.data,column_name=column_name)
    
  }else{
    
    attr(.data,"column_name") <- c(attr(.data,"column_name"),column_name)
  }

    
  if(is.null(attr(.data,"column_name_adj"))){
    
  .data <-   structure(.data,column_name_adj=column_name_adj)
    
  }else{
    
    attr(.data,"column_name_adj") <- c(attr(.data,"column_name_adj"),column_name_adj)
  }
  
   if(is.null(attr(.data,"column_expr_adj"))){
    
  .data <-   structure(.data,column_expr_adj=column_expr_adj)
    
  }else{
    
    attr(.data,"column_expr_adj") <- c(attr(.data,"column_expr_adj"),column_expr_adj)
  }

    
  return(.data)

}

```



```{r}

cp <- function(.data,column,fn="row"){

    
  column_name <- rlang::as_name(rlang::enquo(column))

  # Capture the column name and aggregation function
  column_name_adj <- column_name
  


  if(fn=="row"){
    
  column_expr_adj <- column_name_adj
    
  }else{
  column_expr_adj <- rlang::quo_name(
    rlang::call2(fn, column_name_adj,na.rm=TRUE)
    )
    
  }

 if(is.null(attr(.data,"column_name"))){
    
    .data <- structure(.data,column_name=column_name)
    
  }else{
    
    attr(.data,"column_name") <- c(attr(.data,"column_name"),column_name)
  }

    
  if(is.null(attr(.data,"column_name_adj"))){
    
  .data <-   structure(.data,column_name_adj=column_name_adj)
    
  }else{
    
    attr(.data,"column_name_adj") <- c(attr(.data,"column_name_adj"),column_name_adj)
  }
  
   if(is.null(attr(.data,"column_expr_adj"))){
    
  .data <-   structure(.data,column_expr_adj=column_expr_adj)
    
  }else{
    
    attr(.data,"column_expr_adj") <- c(attr(.data,"column_expr_adj"),column_expr_adj)
  }

    
  return(.data)
}

```


```{r}

d <- function(.data,column,fn="row") {


    
  column_name <- rlang::as_name(rlang::enquo(column))

  # Capture the column name and aggregation function
  column_name_adj <- paste0("delta_",column_name)
  

  if(fn=="row"){
    
  column_expr_adj <- column_name_adj
    
  }else{
    
  column_expr_adj <- rlang::quo_name(
    rlang::call2(fn, column_name_adj,na.rm=TRUE)
    )
  }

 if(is.null(attr(.data,"column_name"))){
    
    .data <- structure(.data,column_name=column_name)
    
  }else{
    
    attr(.data,"column_name") <- c(attr(.data,"column_name"),column_name)
  }

    
  if(is.null(attr(.data,"column_name_adj"))){
    
  .data <-   structure(.data,column_name_adj=column_name_adj)
    
  }else{
    
    attr(.data,"column_name_adj") <- c(attr(.data,"column_name_adj"),column_name_adj)
  }
  
   if(is.null(attr(.data,"column_expr_adj"))){
    
  .data <-   structure(.data,column_expr_adj=column_expr_adj)
    
  }else{
    
    attr(.data,"column_expr_adj") <- c(attr(.data,"column_expr_adj"),column_expr_adj)
  }

    
  return(.data)
  
}
```



```{r}
mtcars |> 
pp(column=quantity,fn = "row") |> 
  cp(column=price,fn="mean") |> 
  d(column=volume,fn="row") |> attributes()

```
```{r}
factor <- function(.data,formula){
  
  formula <- y~x+b+c
  
  args <- attr(terms.formula(formula),"variables")
  
  len <- length(call_lst)-1
  


  
  
    args_lst <- map(
  3:(3+len)
  ,.f = \(x) call_modify(args[[x]],.data=expr(.data))
) |> 
  map(\(x) eval_tidy(x))
  
  

      
new_formula_chr <- reduce2(
    .x=3:(3+len-1)
    ,.y=1:len
    ,.f=\(prev,.x,.y){
      
      prev |>
  str_replace(
    pattern =fixed(expr_name(args[[.x]]))
    ,replacement =  paste0("args_lst[[",.y,"]]")
    )
      
      
    },.init = rlang::expr_name(rlang::f_rhs(formula))
  )

  formula_values_vec <- new_formula_chr |> rlang::parse_expr() |> eval_tidy()
  
  
  
  data[expr_name(target)] <- formula_values_vec


      formula_str <- rlang::expr_name(rlang::f_rhs(formula))
  
}

```





```{r}

library(tidyverse)
library(rlang)


pp <- function(.data,column,fn="row",time_unit) {

  column <- expr(quantity)
  fn <- "mean"
  
  column_str <- rlang::as_name(rlang::enquo(column))

  # Capture the column name and aggregation function

  column_adj_str <- rlang::sym(paste0("lag_",column_str))
  
  ## augment table
  augment_expr <- rlang::expr(
    dplyr::mutate(
     dplyr::across(dplyr::all_of(column_str),\(x) dplyr::lag(x,1),.names = "lag_{.col}")
    )
  )
  # calculate a few tests


  if(fn=="row"){

    out <- list()
    out$out             <- column_adj_str
    out$column_name     <- column_str
    out$column_name_adj <- rlang::as_name(column_adj_str)
    out$augment_expr    <-  augment_expr
    
    return(out)

  }

  # Create a dynamic call to wrap the aggregation function around the column

  fn_column <- rlang::call2(fn, column_adj_str,na.rm=TRUE)
  
    out                 <- list()
    out$out             <- fn_column
    out$column_name     <- column_str
    out$column_name_adj <- rlang::as_name(column_adj_str)
    out$augment_expr    <- augment_expr
    

  return(out)

}


cp <- function(.data,column,fn="row") {


  column_str <- rlang::as_name(rlang::enquo(column))

  column_adj_str <- rlang::sym(column_str)



  if(fn=="row"){

    out <- list()
    out$out             <- column_adj_str
    out$column_name     <- column_str
    out$column_name_adj <- rlang::as_name(column_adj_str)
    
    return(out)

  }

  # Create a dynamic call to wrap the aggregation function around the column

  fn_column <- rlang::call2(fn, column_adj_str,na.rm=TRUE)
  
    out <- list()
    out$out             <- fn_column
    out$column_name     <- column_str
    out$column_name_adj <- rlang::as_name(column_adj_str)
    
  return(out)
}

## need to add pp and cp logic to d so that it checks of the columns exists andif not creats it and then creates the delta from it


d <- function(.data,column,fn="row",time_unit) {

  pp_out <- pp(.data=.data,column=column,fn=fn,time_unit)
  
  cp_out <- cp(.data=.data,column=column,fn=fn,time_unit)
  

  column_str <- rlang::as_name(rlang::enquo(column))

  # Capture the column name and aggregation function

  column_adj_str <- rlang::sym(paste0("delta_",column_str))



 if(fn=="row"){

    out <- list()
    out$out             <- column_adj_str
    out$column_name     <- column_str
    out$column_name_adj <- rlang::as_name(column_adj_str)
    
    return(out)
 }
    
  fn_column <- rlang::call2(fn, column_adj_str,na.rm=TRUE)
  
    out <- list()
    out$out             <- fn_column
    out$column_name     <- column_str
    out$column_name_adj <- rlang::as_name(column_adj_str)
    

  return(out)

}



d(quantity,"sum")

library(rlang)

factor <- function(formula,data,time_unit,by){

formula <- formula(revenue~pp(quantity,"sum")*cp(net_price,"row"))


 formula_terms <- drop.terms(terms(formula),keep.response = FALSE)

formula_terms_call <- attr(formula_terms,"variables")

args_lst <- rlang::eval_tidy(formula_terms_call)

  time_unit <- "month"
  
  lhs      <- rlang::f_lhs(formula)
  
  #pattern to split by arthmetic operators
  call_pattern     <- "(?<!\\w)[\\*\\+/](?!\\w)\\s*|\\s+-\\s*"
  operator_pattern <- "[-*\\+]+"
  
  ## split out the right hand list to seperate call objects as texts

  # rhs_text_lst <- strsplit(rhs_text,call_pattern, perl = TRUE) |> purrr::pluck(1)
  
  ## excute the call objects to get a list of objects

  # args_lst             <- purrr::map(rhs_text_lst,rlang::parse_expr) |> purrr::map(rlang::eval_tidy)
  
  ## pull out each call objects result individually

  # args_call            <- map(seq_along(args_lst),\(.x) args_lst |> pluck(.x,"out") |> rlang::expr_text())
  # args_column_name     <- map(seq_along(args_lst),\(.x) args_lst |> pluck(.x,"column_name"))
  # args_column_name_adj <- map(seq_along(args_lst),\(.x) args_lst |> pluck(.x,"column_name_adj"))
  
  
  ## transform tibble
  sales_tbl |> 
    group_by(
      dplyr::pick(dplyr::all_of(time_unit))
    ) |> 
    group_by(product_key) |> 
    arrange(product_key,month) |> 
    mutate(
      across(unlist(c(lhs_text,args_column_name)),\(x) lag(x,1),.names = "lag_{.col}")
      ,across(unlist(c(lhs_text,args_column_name)),\(x) lag(x,1),.names = "delta_{.col}")
    ) 
  
  pak::pak("dplyrover")
  
  all_column_names <- c(lhs_text,args_column_name,args_column_name_adj) |> unlist()
  
  
  

  # replace each variable one by one

  str_out <- purrr::reduce2(
    
    .x=rhs_text_lst
    
    ,.y=args_call
    
    ,.f = \(prev,.x,.y){

      prev |> gsub(.x,.y,x=_,fixed = TRUE)

    }
    ,.init = rhs_text
  )


  # add to formula new column
  out_obj <- data |>
    dplyr::mutate(!!lhs_text:=!!parse_expr(str_out))

  return(out_obj)
}






sales_slim_tbl <- sales_tbl |> 
  group_by(month) |> 
  mutate(
    total_revenue=sum(revenue)
    ,total_quantity=sum(quantity)
  ) |> 
  group_by(product_key) |> 
  arrange(product_key,month)
  mutate(
    lag_quantity=lag(quantity,1,NA)
    ,lag_revenue=lag(revenue,1,NA)
    ,lag_net_price=lag(net_price,1,NA)
    ,lag_total_revenue=lag(total_revenue,1,NA)
     ,lag_total_quantity=lag(total_quantity,1,NA)
    ,delta_quantity=quantity-lag_quantity
    ,delta_net_price=net_price-lag_net_price
    ,delta_revenue=revenue-lag_revenue
    ,mix=revenue/total_revenue
    ,lag_max=lag_revenue/lag_total_revenue
    ,quantity_prop=quantity/total_quantity
    ,lag_quantity_prop=lag_quantity/lag_total_quantity
  ) |> 
  arrange(product_key) |> 
  drop_na()
  assertthat::assert_that(
    column_str %in% column_names
    ,msg = "Please ensure that the column exists in the dataset"
  )


  assertthat::assert_that(
    .data |> dplyr::pull(column_str) |> is.numeric()
    ,msg = "Please ensure column is numeric"
  )

```



total_x
delta_x
lag_x


I want a function in R that uses the below syntax
formula(net_price~cp(sales,quantity,'row') * pp(sales,quantity_prop,'row') - pp(sales,quantity,'row') *pp(sales,quantity,'row'))

where the final result will be a mutate function where net_price (to the left of ~) is the name of the column and each of 
 cp(sales,quantity,'row'), pp(sales,quantity_prop,'row'),pp(sales,quantity,'row') and pp(sales,quantity,'row') will be captured call objects and executed which will eventually return column names so that mutate will use the armethic indicators against the columns names.