#############################################################################
#   Copyright (c) 2018 Giorgio A. Spedicato
#
#   This program is free software; you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation; either version 2 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program; if not, write to the
#   Free Software Foundation, Inc.,
#   59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
#
#############################################################################
###
###         definitions of classes and methods 
###

#CLASSES DEFINITIONS

# Keep defaults in one place to avoid prototype/initialize drift.
.LIFETABLE_DEFAULT_X <- 0:3
.LIFETABLE_DEFAULT_LX <- c(100, 90, 50, 10)
.LIFETABLE_DEFAULT_NAME <- "Generic life table"
.ACTUARIALTABLE_DEFAULT_NAME <- "Generic actuarial table"
.ACTUARIALTABLE_DEFAULT_INTEREST <- 0.03



setClass("lifetable", #classe lifetable
		slots = c(x = "numeric", lx = "numeric", name = "character")
)
#actuarial classes
setClass("actuarialtable",
		 slots = c(interest = "numeric"),
		 contains = "lifetable"
)

#METHODS DEFINITIONS

#constructor for lifetable object
# lifetable <- function(x = 0:3, lx = c(100,90, 50, 10), name = "Generic life table") {
#   if(length(x) != length(lx)) stop("length of x and lx must be equal")
#   
#   posToRemove <- which(lx %in% c(0,NA))
#   if(length(posToRemove) > 0) {
#     x <- x[-posToRemove]
#     lx <- lx[-posToRemove]
#   }
#   
#   # order by increasing value of x
#   o <- order(x)
#   x <- x[o]
#   lx <- lx[o]
#   
#   out <- new("lifetable", x = x, lx = lx, name = name)
#   return(out)
# }

setMethod(f="initialize",
          signature="lifetable",
		  definition=function(.Object,
							  x = .LIFETABLE_DEFAULT_X,
							  lx = .LIFETABLE_DEFAULT_LX,
							  name = .LIFETABLE_DEFAULT_NAME) {
            
            if(length(x) != length(lx)) stop("length of x and lx must be equal")
          
            posToRemove <- which(lx %in% c(0,NA))
            if(length(posToRemove) > 0) {
              x <- x[-posToRemove]
              lx <- lx[-posToRemove]
            }
            
			# Normalize user input before validity checks.
			# This makes object creation deterministic across call sites.
            o <- order(x)
            x <- x[o]
            lx <- lx[o]
            
            .Object@x <- x
            .Object@lx <- lx
            .Object@name <- name
            validObject(.Object)
            return(.Object)
          }
)


setMethod(f="initialize",
          signature="actuarialtable",
					definition=function(.Object,
															x = .LIFETABLE_DEFAULT_X,
															lx = .LIFETABLE_DEFAULT_LX,
															name = .ACTUARIALTABLE_DEFAULT_NAME,
															interest = .ACTUARIALTABLE_DEFAULT_INTEREST) {
						# Reuse lifetable initialization logic to keep both classes aligned.
						.Object <- callNextMethod(.Object, x=x, lx=lx, name=name)
            .Object@interest <- interest
            validObject(.Object)
            return(.Object)
          }
)


#validity method for lifetable object
setValidity("lifetable",
		function(object) {
			# Return all failing constraints at once for clearer diagnostics.
			check <- character(0)
			if(length(object@x)!=length(object@lx)) 
			  check <- c(check, "x and lx do not match in length")
			if(any(diff(object@lx)>0)) 
			  check <- c(check, "lx must be non-increasing")
			if(any(abs(object@x - floor(object@x)) > 0))
			  check <- c(check, "x must be integral")
			if(any(object@x < 0))
			  check <- c(check, "x must be non-negative")
			if(any(diff(object@x) != 1))
			  check <- c(check, "x must be consecutive integers")
			
			if(length(check) == 0) 
			  return(TRUE) 
			else 
				return(check)
		}
)






#function to create lifetable cols
.createLifeTableCols<-function(object)
{
	#vector used to obtain px
	lxplus<-object@lx[2:length(object@lx)]
	lxplus<-c(lxplus,0)
	# Under UDD (fxt = 0.5 in Lxt), Lx = lx - 0.5*dx = (lx + lx+1)/2.
	Lx <- 0.5 * (object@lx + lxplus)
	# Tx is the backward cumulative sum of Lx.
	Tx <- rev(cumsum(rev(Lx)))
	# ex is intentionally computed via exn() to keep this output aligned
	# with the package's expected-lifetime implementation.
	lenlx=length(object@lx)
	exni=numeric(lenlx)
	for(i in seq_len(lenlx)) exni[i]=exn(object=object, x=i-1,type="curtate") #prima x=i e come sopra e c'era complete
	out<-data.frame(x=object@x, lx=object@lx,px=lxplus/object@lx,
			Lx=Lx, Tx=Tx, ex=exni)
	#remove last row
	out<-out[1:(nrow(out)-1),]
	rownames(out)=NULL
	return(out)
}

.printLifetable <- function(object)
{
	cat(paste("Life table",object@name),"\n")
	cat("\n")
	print(.createLifeTableCols(object))
	cat("\n")
}

#show method 4 lifetable: prints x, lx, px, ex
setMethod("show","lifetable", #metodo show
		function(object){
			.printLifetable(object)
		}
)

#show method 4 lifetable: prints x, lx, px, ex
setMethod("print","lifetable", #metodo show
		function(x){
			.printLifetable(x)
		}
)

#head and tail methods
setMethod("head",
		signature(x = "lifetable"),
		function (x, ...) 
		{
			temp<-data.frame(x=x@x, lx=x@lx)
			head(temp)
		}
)

#summary

setMethod("summary",
		signature(object="lifetable"),
		function (object, ...)
		{
			cat("This is lifetable: ",object@name, "\n","Omega age is: ",getOmega(object), "\n", "Expected curtated lifetime at birth is: ",exn(object))
		}
)

setMethod("summary",
		signature(object="actuarialtable"),
		function (object, ...)
		{
			cat("This is lifetable: ",object@name, "\n","Omega age is: ",getOmega(object), "\n", 
					"Expected curtated lifetime at birth is: ",exn(object),
					"Interest rate used is:",object@interest)
		}
)


#tail
setMethod("tail",
		signature(x = "lifetable"),
		function (x, ...) 
		{
			temp<-data.frame(x=x@x, lx=x@lx)
			tail(temp)
		}
)
#internal function to create the actuarial table object
.createActuarialTableCols<-function(object)
{
	#vector used to obtain px
	lxplus<-object@lx[2:length(object@lx)]
	lxplus<-c(lxplus,0)
	#Dx
	Dx=object@lx*(1+object@interest)^(-object@x)
	#Cx
	dx=object@lx-lxplus
	Cx=dx*(1+object@interest)^(-object@x-1)	
	#Nx: cumulative commutation sum from last age backward.
	Nx=rev(cumsum(rev(Dx)))
	#Mx
	Mx=Dx-(object@interest/(1+object@interest))*Nx
	#Rx: cumulative sum of Mx from last age backward.
	Rx=rev(cumsum(rev(Mx)))
	out<-data.frame(x=object@x, lx=object@lx, Dx=Dx, Nx=Nx, Cx=Cx,
			Mx=Mx, Rx=Rx)
	rownames(out)=NULL
	return(out)
	
}

.printActuarialtable <- function(object)
{
	cat(paste("Actuarial table ",object@name, "interest rate ", object@interest*100,"%"),"\n")
	cat("\n")
	print(.createActuarialTableCols(object=object))
	cat("\n")
}

setMethod("show","actuarialtable", #metodo show
		function(object){
			.printActuarialtable(object)
		}
)

#print method: show clone

setMethod("print","actuarialtable", #metodo show
		function(x){
			.printActuarialtable(x)
		}
)


setMethod("plot","lifetable",
		function(x,y,...){
			plot(x=x@x, y=x@lx, xlab="x values", 
					ylab="population at risk", 
					main=paste("life table",x@name),...)
		}
)
#saves lifeTableObj as data frame
setAs("lifetable","data.frame",
		function(from){
			out<-.createLifeTableCols(object=from)
			return(out)
		}
)

#get a data.frame containing x and lx and returns a new lifetable object
setAs(from="data.frame",to="lifetable",
		def=function(from){
			if(any(is.na(match(c("x","lx"), names(from))))) stop("Error! Both x and lx columns required!")
			from<-from[complete.cases(from),]
			out<-new("lifetable",x=from$x, lx=from$lx, name="COERCED")
			return(out)
		}
)

#saves actuarialtable as data frame (have same slots as life - table)
setAs("actuarialtable","data.frame",
		function(from){
			out<-.createActuarialTableCols(object=from)
			return(out)
		}
)

#coerce methods to numeric

setAs("lifetable","numeric",
		function(from) {
			out<-numeric(getOmega(from)+1)
			for(i in 0:getOmega(from)) out[i+1]<-qxt(object=from,x=i,t=1)
			return(out)
		}
)

setAs("actuarialtable","numeric",
		function(from) {
			out<-numeric(getOmega(from))
			for(i in 0:(getOmega(from)-2)) out[i+1]<-Axn(actuarialtable=from,x=i)
			return(out)
		}
)

#demographic classes and methods

#setGeneric("pxt", function(object) standardGeneric("pxt"))
#setGeneric("qxt", function(object) standardGeneric("qxt"))