.packageName <- "actuar"
"bstraub" <-
function(ratios, weights, heterogeneity=c("iterative","unbiased"),TOL=1E-6, echo=FALSE )
{
    ## If weights are not specified, use equal weights as in
    ## Bhlmann's model.
    if (missing(weights))
    {
        if (!identical(0, sum(is.na(ratios))))
            stop("missing values are not allowed in the matrix of ratios when the matrix of weights is not specified")
        weights <- array(1, dim(ratios))
    }

    ## Check other bad arguments.
    if (ncol(ratios) < 2)
        stop("there must be at least one contract with at least two years of experience")
    if (nrow(ratios) < 2)
        stop("there must be more than one contract")
    if(!identical(which(is.na(ratios)), which(is.na(weights))))
        stop("missing values are not in the same positions in the matrix of weights and the matrix of ratios")

    ## Individual weighted averages. It could happen that a contract
    ## has no observations, for example when applying the model on
    ## claim amounts. In such a situation, we will put the total
    ## weight of the contract and the weighted average both equal to
    ## zero. That way, the premium will be equal to the credibility
    ## weighted average, as it should, but the contract will have no
    ## contribution in the calculations.
    weights.s <- rowSums(weights, na.rm=TRUE)
    ratios.w <- ifelse(weights.s > 0, rowSums(weights * ratios, na.rm=TRUE) / weights.s, 0)

    ## Size of the portfolio.
    ncontracts <- sum(weights.s > 0)
    ntotal <- sum(!is.na(weights))

    ## Collective weighted average.
    weights.ss <- sum(weights.s)
    ratios.ww <- sum(weights.s * ratios.w) / weights.ss

    ## Estimation of s^2.
    s2 <-  sum(weights * (ratios - ratios.w)^2, na.rm=TRUE) / (ntotal - ncontracts)

    ## First estimation of a. Always compute the unbiased estimator.
    ac <- weights.ss * (sum(weights.s * (ratios.w - ratios.ww)^2) - (ncontracts - 1) * s2) / (weights.ss^2 - sum(weights.s^2))

    ## Iterative estimation of a. Compute only if
    ## 1. asked to in argument;
    ## 2. the unbiased estimator is > 0;
    ## 3. weights are not all equal (Bhlmann model).
    heterogeneity <- match.arg(heterogeneity)

    if (identical(heterogeneity, "iterative"))
    {
        if (ac > 0)
        {
            if (diff(range(weights, na.rm = TRUE)) > .Machine$double.eps^0.5)
            {
                if (echo)
                    exp <- expression(print(at1 <-  at))
                else
                    exp <- expression(at1 <-  at)

                at <- ac
                repeat
                {
                    eval(exp)

                    cred <- 1 / (1 + s2/(weights.s * at))
                    ratios.zw <- sum(cred * ratios.w) / sum(cred)
                    at <- sum(cred * (ratios.w - ratios.zw)^2) / (ncontracts - 1)

                    if (abs((at - at1)/at1) < TOL)
                        break
                }
            }
            else
                at <- ac
        }
        else
            at <- 0
        a <- at
    }
    else
    {
        a <- ac
        at <- NULL
    }

    ## Final credibility factors and estimator of the collective mean.
    if (a > 0)
    {
        cred <- 1 / (1 + s2/(weights.s * a))
        ratios.zw <- sum(cred * ratios.w) / sum(cred)
    }
    else
    {
        cred <- 0
        ratios.zw <- ratios.ww
    }

    ## Credibility premiums.
    P <- ratios.zw + cred * (ratios.w - ratios.zw)

    list(premiums=P,
         individual=ratios.w,
         collective=ratios.zw,
         weights=weights.s,
         s2=s2,
         unbiased=ac,
         iterative=at)
}
"panjer" <-
function(fx, freq.dist=c("poisson", "negative binomial", "binomial","geometric","logarithmic"), par, p0, TOL=1E-8, echo=FALSE)
{
    ## Express TOL as a value close to 1.
    TOL <- 1 - TOL

    ## f_X(0) is no longer needed after the calculation of f_S(0).
    fx0 <- fx[1]
    fx <- fx[-1]

    ## Distributions are expressed as a member of the (a, b, 0) or (a,
    ## b, 1) families of distributions. Assign parameters 'a' and 'b'
    ## depending of the chosen distribution and compute f_S(0) in
    ## every case, and p1 if p0 is specified in argument.
    dist <- match.arg(freq.dist)
    if (dist == "geometric")
    {
        dist <- "negative binomial"
        par$size <- 1
    }

    if (dist == "poisson")
    {
        lambda <- par$lambda
        a <- 0
        b <- lambda

        if (missing(p0))
            fs0 <- exp(-lambda * (1 - fx0))
        else
        {
            fs0 <- p0 + (1 - p0)*(exp(lambda * fx0) - 1)/(exp(lambda) - 1)
            p1 <- (1 - p0) * lambda/(exp(lambda) - 1)
        }
    }
    else if (dist == "negative binomial")
    {
        beta <- 1/(par$prob) - 1
        r <- par$size
        a <- beta/(1 + beta)
        b <- (r - 1) * a
        if (missing(p0))
            fs0 <- (1 - beta * (fx0 - 1))^(-r)
        else
        {
            fs0 <- p0 + (1 - p0) * ((1 + beta * (1 - fx0))^(-r) - (1 + beta)^(-r))/(1 - (1 + beta)^(-r))
            p1 <- (1 - p0) * r * beta/((1 + beta)^(r+1) - (1 + beta))
        }
    }
    else if (dist == "binomial")
    {
        m <- par$size
        q <- par$prob
        a <- - q/(1 - q)
        b <- -(m + 1)*a
        if (missing(p0))
            fs0 <- (1 + q * (fx0 - 1))^m
        else
        {
            fs0 <- p0 + (1 - p0)*((1 + q * (fx0 - 1))^m - (1 - q)^m)/(1 - (1 - q)^m)
            p1 <- (1 - p0) * m * (1 - q)^(m - 1) * q/(1 - (1 - q)^m)
        }
    }
    else if (dist == "logarithmic")
    {
        if (missing(p0))
            stop("p0 must be specified with the logarithmic distribution")
        beta <- (1/par$prob) - 1
        a <- beta/(1 + beta)
        b <- -a
        fs0 <- p0 + (1 - p0)*(1 - log(1 - beta(fx0 - 1))/log(1 + beta))
        p1 <- beta/((1 + beta) * log(1 + beta))
    }

    ## If fs0 is equal to zero, the recursion will not start. There is
    ## no provision to automatically cope with this situation in the
    ## current version of this version. Just issue an error message
    ## and let the user do the work by hand.
    if (identical(fs0, 0))
        stop("the value of fs0 is equal to 0; impossible to start the recursion")

    ## The recursion formula is slightly different for the (a, b, 0)
    ## and (a, b, 1) cases. We do the split here to avoid repeatedly
    ## testing in which case we're in.
    ##
    ## Vector 'fs' will hold the probabilities and will be expanded as
    ## needed. We are not supposed to do that in S, but assigning a
    ## longer than needed vector of NAs proved cumbersome and slower.
    fs <- fs0
    cumul <- sum(fs)

    ## (a, b, 0) case
    if (missing(p0))
    {
        ## See in the (a, b, 1) case why this is defined here.
        r <- length(fx)

        repeat
        {
            if (echo)
                print(tail(cumul, 1))

            x <- length(fs)
            m <- min(x, r)
            fs <- c(fs, sum((a + b * 1:m / x) * head(fx, m) * rev(tail(fs, m)))/(1 - a * fx0))
            if (TOL < (cumul <- cumul + tail(fs, 1)))
                break
        }
    }
    ## (a, b, 1) case
    else
    {
        ## Line below is a hack to reproduce the fact that the
        ## distribution of claim amounts is 0 past its maximum
        ## value. Only needed in the (a, b, 1) case for the additional
        ## term in the recursion formula.
        fx <- c(fx, 0)
        r <- length(fx)
        const <- p1 - (a + b) * p0

        repeat
        {
            if (echo)
                print(tail(cumul, 1))

            x <- length(fs)
            m <- min(x, r)
            fs <- c(fs, (const * fx[m] + sum((a + b * 1:m / x) * head(fx, m) * rev(tail(fs, m))))/(1 - a * fx0))
            if (TOL < (cumul <- cumul + tail(fs, 1)))
                break
        }
    }
    fs
}

"rearrangepf" <-
function(pf)
{
    ## Number of years of observations.
    years <- ncol(pf)

    ## Matrix of the aggregate claim amounts.
    aggregate <- array(dim=dim(pf), sapply(pf, sum))

    ## Matrix of the claim numbers.
    frequencies <- array(dim=dim(pf), sapply(pf, length))

    ## Matrix of the individual claim amounts for the first n - 1
    ## years. Forming this matrix is complicated by the fact that the
    ## number of claims is potentially different for each contract.
    ##
    ## Total number of claims per contract; use 'drop=FALSE' in case
    ## there is only one contract.
    nclaims <- rowSums(frequencies[,1:(years-1), drop=FALSE])

    ## Initialization of the matrix.
    claims <- matrix(NA, nrow(pf), max(nclaims))

    ## Filling of the matrix, contract per contract, only is positions
    ## where there is a claim.
    for (i in 1:nrow(pf))
    {
        if (0 < (nclaimsi <- nclaims[i]))
            claims[i, 1:nclaimsi] <- unlist(pf[i,])[1:nclaimsi]
    }

    ## Matrix of the individual claim amounts for the last
    ## year. Identical to above.
    nclaims <- frequencies[,years]
    claims.last <- matrix(NA, nrow(pf), max(nclaims))
    for (i in 1:nrow(pf))
    {
        if (0 < (nclaimsi <- nclaims[i]))
            claims.last[i, 1:nclaimsi] <- tail(unlist(pf[i,]), nclaimsi)
    }

    list(aggregate=aggregate,
         frequencies=frequencies,
         severities=list(claims=claims, claims.last=claims.last))
}

"simpf" <-
function(contracts, years, model.freq, model.sev, weights)
{
    ## Assign a matrix of weights if none are given in argument.
    if (missing(weights))
        weights <- matrix(1, contracts, years)

    ## Verify that the dimensions of the weights matrix match the
    ## 'contracts' and 'years' arguments.
    if (!isTRUE(all.equal(dim(weights), c(contracts, years))))
        stop(paste("dimensions of matrix 'weights' should be c(", contracts, ", ", years, ")", sep=""))

    ## Total number of observations in the portfolio (used often).
    nobs <- contracts * years

    ## Simulation of the frequencies. If 'model.freq' is NULL, this is
    ## equivalent to having one claim per contract per
    ## year. Otherwise, the number of claims is simulated for each
    ## contract and each year.
    if (is.null(model.freq))
    {
        N <- rep(1, nobs)
    }
    else
    {
        ## Get the frequency simulation function.
        rfreq <- match.fun(paste("r", model.freq$dist1, sep=""))

        ## The presence of the string "Lambda" in model.freq$par1
        ## indicates a compound model. If present, then we have to
        ## simulate the values of the compounding parameter using the
        ## distribution specified in model.freq$dist2. Otherwise, we
        ## simply simulate from the specified distribution.
        if (is.na(pmatch("Lambda", as.character(model.freq$par1))))
        {
            ## If there is no compounding parameter but a compounding
            ## distribution is specified, issue a warning.
            if (exists("model.freq$dist2"))
                warning("A compounding distribution for the frequency of claims is specified, but no compounding parameter")
        }
        else
        {
            ## Get the compounding distribution simulation function and set
            ## its parameters.
            rlambda <- match.fun(paste("r", model.freq$dist2, sep=""))
            formals(rlambda)[names(model.freq$par2)] <- model.freq$par2

            ## Simulation of the compounding parameters (frequency risk levels).
            Lambda <- rlambda(contracts)
        }


        ## Set the parameters of the frequency distribution by
        ## evaluating the expression in 'Lambda' and/or 'weights'
        ## given in model.freq$par1.
        formals(rfreq)[names(model.freq$par1)] <- lapply(model.freq$par1, eval.parent)

        ## Simulation of the number of claims per year and per
        ## contract (vector Lambda, if any, is recycled).
        N <- rfreq(nobs)
    }

    ## Simulation of the claim amounts. If 'model.sev' is NULL, this
    ## is equivalent to simulating frequencies only. Otherwise, claim
    ## amounts are simulated for each claim.
    if (is.null(model.sev))
    {
        X <- N
    }
    else
    {
        ## Get the severity simulation function.
        rsev <- match.fun(paste("r", model.sev$dist1, sep=""))

        ## The presence of the string "Theta" in model.sev$par1
        ## indicates a compound model. If present, then we have to
        ## simulate the values of the compounding parameter using the
        ## distribution specified in model.sev$dist2. Otherwise, we
        ## simply simulate from the specified distribution.
       if (is.na(pmatch("Theta", as.character(model.sev$par1))))
       {
            ## If there is no compounding parameter but a compounding
            ## distribution is specified, issue a warning.
            if (exists("model.sev$dist2"))
                warning("A compounding distribution for the amount of claims is specified, but no compounding parameter")

            ## Set the parameters of the severity distribution.
            formals(rsev)[names(model.sev$par1)] <- model.sev$par1

            ## Since the parameters of the severity distribution do
            ## not change from one contract to another, we can
            ## immediately simulate all claim amounts.
            X <- sapply(N, rsev)
        }
        else
        {
            ## Get the compounding distribution simulation function and set
            ## its parameters.
            rtheta <- match.fun(paste("r", model.sev$dist2, sep=""))
            formals(rtheta)[names(model.sev$par2)] <- model.sev$par2

            ## Simulation of the compounding parameters (severity risk levels).
            Theta <- rtheta(contracts)

            ## Simulation of claim amounts in the case of a compound
            ## model is more complicated since the severity risk
            ## parameter (potentially) changes from one contract to
            ## another. We must therefore be able to distinguish which
            ## Theta to use for each claim amount simulation. For
            ## this, every occurence of 'Theta' in the severity
            ## distributions parameters must be replaced by 'Theta[i]'.
            model.sev$par1 <- lapply(model.sev$par1, function(x) parse(text=sub("Theta", "Theta[i]", deparse(x))))

            ## We then use an auxiliary function (to be used in
            ## lapply()) to run through all contracts and years. It
            ## will choose the correct Theta to use.
            f <- function(j)
            {
                ## index of the contract to simulate
                i <- 1 + (j - 1) %% contracts

                ## set the parameters of the severity distribution;
                ## this is where the '[i]' pasted above is used
                formals(rsev)[names(model.sev$par1)] <- lapply(model.sev$par1, function(x) {force(i); eval(x)})

                ## simulation of claim amounts for this contract
               rsev(N[j])
            }

            ## Simulation of claim amounts for every contract and year.
            X <- sapply(1:nobs, f)
        }
    }

    ## Return individual claim amounts as a two dimension list or
    ## simple matrix, if possible.
    dim(X) <- c(contracts, years)
    list(data=X, weights=weights)
}

