Skip to content

Commit

Permalink
Incorporate new price dynamic functions
Browse files Browse the repository at this point in the history
  • Loading branch information
@MirenAltuna
MirenAltuna committed Jul 9, 2024
1 parent 048f1b4 commit 415e288
Show file tree
Hide file tree
Showing 2 changed files with 189 additions and 37 deletions.
222 changes: 187 additions & 35 deletions R/OM_2c_Price_Dynamics.R
View file
Original file line number Diff line number Diff line change
@@ -1,69 +1,221 @@
#-------------------------------------------------------------------------------
# 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)
}

#-------------------------------------------------------------------------------
# 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)
}
4 changes: 2 additions & 2 deletions README.md
View file
Original file line number Diff line number Diff line change
@@ -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 <[email protected]>; FLBEIA Team <[email protected]>
- Maintainer: Dorleta GARCIA, AZTI & FLBEIA Team
- Repository: <https://github.com/flr/FLBEIA/>
Expand Down

0 comments on commit 415e288

Please sign in to comment.