From 415e288510a4d780732a29a6333caefa281daa6f Mon Sep 17 00:00:00 2001 From: MirenAltuna Date: Tue, 9 Jul 2024 08:54:55 +0200 Subject: [PATCH] Incorporate new price dynamic functions --- R/OM_2c_Price_Dynamics.R | 222 +++++++++++++++++++++++++++++++++------ README.md | 4 +- 2 files changed, 189 insertions(+), 37 deletions(-) diff --git a/R/OM_2c_Price_Dynamics.R b/R/OM_2c_Price_Dynamics.R index feca141..b8bb7f0 100644 --- a/R/OM_2c_Price_Dynamics.R +++ b/R/OM_2c_Price_Dynamics.R @@ -1,19 +1,36 @@ #------------------------------------------------------------------------------- # PRICE DYNAMIC FUNCTIONS -# Functions to calculate and update the price +# Functions to calculate and update the price # -# - 'fixedPrice' - The Price is given as input, just return the object as it is. -# - 'elasticPrice.total' - elasticity function to model the price (total landings). (Kraak. 2004) -# - 'elasticPrice.fleet' - elasticity function to model the price (fleets' landings). (Kraak. 2004) -# Dorleta GarcYYYa +# - 'fixedPrice' - The Price is given as input, just return the object as it is. +# - 'elasticPrice' - Elasticity function to model the price using the same elastic price function for all ages. +# - 'elasticPriceAge' - Elasticity function to model the price using different elastic price function for each ages. +# +# +### In 'elasticPrice' and 'elasticPriceAge' +# +## Using the 'total' argument, you can choose to condition the price function based on the total landings (TRUE) or on the landings of the fleet in question (FALSE). +# +## Using the 'type' argument you can choose the elasticity function +# - 'type1' - The price varies according to Kraak’s elasticity function (Kraak. 2004). +# - 'type2' - The price varies according to Isabella’s function 3. +# - 'type3' - The price varies according to Isabella’s function 1. +# - 'type4' - The price varies according to Isabella’s function 4. +# - 'type5' - 'fixedPrice'. This option is only available in 'elasticPriceAge'. +# +## Using the 'RP' argument, you can choose to increase or decrease the price by a specific percentage once the new price is calculated. +# +# +# Dorleta García # Created: 09/11/2010 09:56:11 -# Changed:30/11/2010 12:22:06 +# Changed: 30/11/2010 12:22:06 +# +# New types of elasticity functions were added by Miren Altuna-Etxabe: 05/07/2024 #------------------------------------------------------------------------------- #------------------------------------------------------------------------------- -# fixedPrice(fleets, fleets.ctrl, year = 1, season = 1) -# - Two options: +# fixedPrice(fleets, covars, fleets.ctrl, year = 1, season = 1) #------------------------------------------------------------------------------- fixedPrice <- function(fleets, covars, fleets.ctrl, year = 1, season = 1,...){ return(fleets) @@ -21,49 +38,184 @@ fixedPrice <- function(fleets, covars, fleets.ctrl, year = 1, season = 1,...){ #------------------------------------------------------------------------------- # elasticPrice(fleets, covars, fleets.ctrl, stnm, flnm, year = 1, season = 1) -# The price varies according to Kraak elasticity function and are conditioned -# to the total or fleet's landings. -# By means of 'covar' we could analyse the effect of imports in a more -# sophisticated function #------------------------------------------------------------------------------- elasticPrice <- function(fleets, covars, fleets.ctrl, stnm, flnm, mtnm, year = 1, season = 1){ - # Parameters - elas <- fleets.ctrl[[flnm]][[mtnm]][[stnm]][['pd.els']][,season,] # [na,it] the price and its parameters depend on season. - La0 <- fleets.ctrl[[flnm]][[mtnm]][[stnm]][['pd.La0']][,season,] # [na,it] the price and its parameters depend on season. - Pa0 <- fleets.ctrl[[flnm]][[mtnm]][[stnm]][['pd.Pa0']][,season,] # [na,it] the price and its parameters depend on season. - total <- fleets.ctrl[[flnm]][[mtnm]][[stnm]][['pd.total']] # Logic: The function depends on total landings or fleet's landings + fms <- fleets[[flnm]][[mtnm]][[stnm]] + fms.ctrl <- fleets.ctrl[[flnm]][[mtnm]][[stnm]] - fms <- fleets[[flnm]][[mtnm]][[stnm]] yr <- year ss <- season - # Landings. + # Parameters + elsa <- fms.ctrl[['pd.elsa']][,ss,,,] # [na,it] Price-landing elasticity. + La0 <- fms.ctrl[['pd.La0']][,ss,,,] # [na,it] Base landings. + Pa0 <- fms.ctrl[['pd.Pa0']][,ss,,,] # [na,it] Base price. + type <- fms.ctrl[["type"]] # [n,it] Numeric vector + total <- fms.ctrl[['pd.total']] # Logic: If TRUE, the function depends on total landings, and if FALSE on the landings of the fleet in question. + if(is.null(fms.ctrl[['pd.RP']])){RP <- FALSE # By default the price function does not have an added increase/decrease. + } else{ + RP <- fms.ctrl[['pd.RP']] # Logic: If TRUE, the function has an added increase/decrease, and if FALSE it does not. + addRP <- fms.ctrl[['pd.addRP']] # [n,it] Percentage of the price increased/decreased. Same for all ages. + yr.addRP <- fms.ctrl[['pd.yr']] # [n,it] Numeric vector. The year from which the price starts increasing or decreasing annually. + } + + # Landings if(total == TRUE){ - Lau <- landWStock(fleets, stnm)[,yr,,ss] -# print('TOTAL') + Lau <- landWStock(fleets, stnm)[,yr,,ss] + Lau_init <- landWStock(fleets, stnm)[,yr-1,,ss] + Lau_hist <- landWStock(fleets, stnm)[,,,ss] }else{ - Lau <- fms@landings.wt[,yr,,ss] - # print('FLEET') - } - - La <- unitSums(Lau)[drop=T] # [na,it] - nu <- dim(Lau)[3] - - La[La==0] <- 0.001 + Lau <- fms@landings.wt[,yr,,ss] * fms@landings.n[,yr,,ss] + Lau_init <- fms@landings.wt[,yr-1,,ss] * fms@landings.n[,yr-1,,ss] + Lau_hist <- fms@landings.wt[,,,ss] * fms@landings.n[,,,ss] + } + + La_f <- unitSums(Lau)[drop=T] + La_init <- unitSums(Lau_init)[drop=T] + La_hist <- unitSums(Lau_hist)[drop=T] + + # Type + if(type == 1) { P <- Pa0*(La0/La_f)^elsa } + + if(type == 2 | type == 3 | type == 4) { + els <- quantMeans(elsa) # [n,it] + L_f <- sum(La_f) # [n,it] + L_init <- sum(La_init) # [n,it] + L_hist <- colSums(La_hist) # [n,it] + P_init <- quantMeans(fms@price[, yr-1, , ss]) # [n,it] - Pa <- Pa0*(La0/La)^elas # [na,it] + if(L_f == 0){P <- NA # When L_f = 0 -> set P = NA + } else{ + if(L_init== 0) { + L_hist[is.na(L_hist)] <- 0 + filtered_L <- L_hist[L_hist != 0] # Remove years with no landing data. + Last_Lyr <- max(as.numeric(names(filtered_L))) # Identify the last year with landing != 0. + L_init <- as.numeric(L_hist[names(L_hist)== Last_Lyr]) # Take the last landing != 0. + P_init <- quantMeans(fms@price[, grepl(Last_Lyr, names(L_hist)), , ss]) # Take the corresponding price data. + } + if(type == 2){P <- P_init*(L_f/L_init)^els} + if(type == 3){P <- P_init*(1+els*((L_f-L_init)/L_init))} + if(type == 4){P <- P_init*exp(els*L_f)} + } + } - # When La = 0 -> Pa = Inf -> set Pa = NA - Pa <- ifelse( Pa==Inf, NA, Pa) - - fms@price[,yr,,ss] <- Pa + P <- ifelse(P == Inf, NA, P) # When L_f = 0 -> P = Inf -> set P = NA + + # Added increase/decrease in Price. + if(RP == TRUE){ + if(type == 1){ + yr.addRP.pos <- which(colnames(La_hist) %in% yr.addRP) # Identify the position of the year from which the price starts increasing or decreasing annually. + nyr <- yr-yr.addRP.pos+1 # Number of years since the first year of the simulation. + } else{ + P_data <- quantMeans(fms@price[, 1:(yr-1), , ss]) + P_data[is.na(P_data)] <- 0 + filtered_P <- P_data[P_data != 0] # Remove years with no price data. + Last_Pyr <- max(as.numeric(colnames(filtered_P))) # Identify the last year with price data != 0. + + yr.name <- as.numeric(colnames(La_hist)[yr]) # Actual year + nyr <- length(yr.name:Last_Pyr)-1 # Number of years since the last price data. + } + P <- P*(1+addRP)^nyr + } + + fms@price[, yr, , ss] <- P - fleets[[flnm]]@metiers[[mtnm]]@catches[[stnm]] <- fms return(fleets) } + +#------------------------------------------------------------------------------- +# elasticPriceAge(fleets, covars, fleets.ctrl, stnm, flnm, mtnm, year = 1, season = 1) +#------------------------------------------------------------------------------- + +elasticPriceAge <- function(fleets, covars, fleets.ctrl, stnm, flnm, mtnm, year = 1, season = 1){ + + fms <- fleets[[flnm]][[mtnm]][[stnm]] + fms.ctrl <- fleets.ctrl[[flnm]][[mtnm]][[stnm]] + + yr <- year + ss <- season + + # Parameters + elsa <- fms.ctrl[['pd.elsa']][,ss,,,] # [na,it] Price-landing elasticity. + La0 <- fms.ctrl[['pd.La0']][,ss,,,] # [na,it] Base landings. + Pa0 <- fms.ctrl[['pd.Pa0']][,ss,,,] # [na,it] Base price. + type <- fms.ctrl[["type"]] # [na,it] Numeric vector: The type depend on age. + total <- fms.ctrl[['pd.total']] # Logic: If TRUE, the function depends on total landings, and if FALSE on the landings of the fleet in question. + + if(is.null(fms.ctrl[['pd.RP']])) {RP <- FALSE # By default the price function does not have an added increase/decrease. + } else{ + RP <- fms.ctrl[['pd.RP']] # Logic: If TRUE, the function has an added increase/decrease, and if FALSE it does not. + addRP <- fms.ctrl[['pd.addRP']] # [n,it] Percentage of the price increased/decreased. Same for all ages. + yr.addRP <- fms.ctrl[['pd.yr']] # [n,it] Numeric vector. The year from which the price starts increasing or decreasing annually. + } + + # Landings + if(total == TRUE){ + Lau <- landWStock(fleets, stnm)[,yr,,ss] + Lau_init <- landWStock(fleets, stnm)[,yr-1,,ss] + Lau_hist <- landWStock(fleets, stnm)[,,,ss] + }else{ + Lau <- fms@landings.wt[,yr,,ss] * fms@landings.n[,yr,,ss] + Lau_init <- fms@landings.wt[,yr-1,,ss] * fms@landings.n[,yr-1,,ss] + Lau_hist <- fms@landings.wt[,,,ss] * fms@landings.n[,,,ss] + } + + La_f <- unitSums(Lau)[drop=T] + La_init <- unitSums(Lau_init)[drop=T] + La_hist <- unitSums(Lau_hist)[drop=T] + Pa_init <- fms@price[, yr-1, , ss] # [na,it] + + # Type + for(a in 1:length(fms@range[["min"]]:fms@range[["max"]])){ + + tpa <- type[a] # Price function of age a + + if(tpa == 1){Pa <- Pa0[a]*(La0[a]/La_f[a])^elsa[a] + } else { + if(La_f[a] == 0){Pa <- NA # When L_f = 0 -> set P = NA + } else{ + if(La_init[a]== 0) { + La_hist[a,][is.na(La_hist[a,])] <- 0 + filtered_La <- La_hist[a,][La_hist[a,] != 0] # Remove years with no landing data. + Last_Layr <- max(as.numeric(names(filtered_La))) # Identify the last year with landing != 0. + La_init <- as.numeric(La_hist[,colnames(La_hist)== Last_Layr]) # Take the last landing =! 0. + Pa_init <- fms@price[, grepl(Last_Layr, colnames(La_hist)), , ss] # Take the corresponding price data. + } + } + if(tpa == 2){Pa <- Pa_init[a]*(La_f[a]/La_init[a])^elsa[a]} + if(tpa == 3){Pa <- Pa_init[a]*(1+elsa[a]*((La_f[a]-La_init[a])/La_init[a]))} + if(tpa == 4){Pa <- Pa_init[a]*exp(elsa[a]*La_f[a])} + if(tpa == 5){Pa <- elsa[a]} + } + + Pa <- ifelse( Pa==Inf, NA, Pa) # When La_f = 0 -> Pa = Inf -> set Pa = NA + + # Added increase/decrease in Price. + if(RP == TRUE){ + if(tpa == 1 | tpa == 5){ + yr.addRP.pos <- which(colnames(La_hist) %in% yr.addRP) # Identify the position of the year from which the price starts increasing or decreasing annually. + nyr <- yr-yr.addRP.pos+1 # Number of years since the first year of the simulation. + } else{ + P_data <- quantMeans(fms@price[, 1:(yr-1), , ss]) + P_data[is.na(P_data)] <- 0 + filtered_P <- P_data[P_data != 0] # Remove years with no price data. + Last_Pyr <- max(as.numeric(colnames(filtered_P))) # Identify the last year with price data != 0. + + yr.name <- as.numeric(colnames(La_hist)[yr]) # Actual year. + nyr <- length(yr.name:Last_Pyr)-1 # Number of years since the last price data. + } + Pa <- Pa*(1+addRP)^nyr + } + fms@price[a,yr,,ss] <- Pa # [na,it] + } + + fleets[[flnm]]@metiers[[mtnm]]@catches[[stnm]] <- fms + + return(fleets) +} diff --git a/README.md b/README.md index 7841c47..5513518 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # FLBEIA -- Version: 1.16.1.16 -- Date: 2024-05-28 +- Version: 1.16.1.17 +- Date: 2024-07-09 - Author: Dorleta GARCIA ; FLBEIA Team - Maintainer: Dorleta GARCIA, AZTI & FLBEIA Team - Repository: