.packageName <- "financial"
"cf" <-
function (x,i=NULL,safe=NULL,rein=safe) 
{
cfnfv = function (x,i) 
{
        return(cfnpv(x,i)*spfv(i,length(x)-1))
}

cfnpv = function (x,i) 
{
        npv = c()       

for (k in 1:length(i)) 
{
        n = length(x)
        j = 0:(n-1)
        pvs = x * sppv(i[k],j)
        npv = c(npv,sum(pvs))
}

return(npv);

}

cfnus = function (x,i) 
{
        cfnpv(x,i)/uspv(i,length(x)-1);
}

cfirr = function (x) 
{
	res = polyroot(x)
	res = Re(res[abs(Im(res))<1e-10]);
	res = (1/res-1)*100;
	return(sort(res));

}

cfext = function (x) 
{
	deriv = x[2:length(x)]
	deriv = deriv*(1:length(deriv));
	res = polyroot(deriv)
	res = Re(res[abs(Im(res))<1e-10]);
	res = (1/res-1)*100;
	return(sort(res));

}


	res = list();
	tab = c();

	if(!is.null(safe)) {

		nn = max(c(length(safe),length(rein)));
		safe=safe+rep(0,nn);
		rein=rein+rep(0,nn);
		modcf=x; modcf[modcf<0]=0;
		nfvp=cfnfv(modcf,rein);
		modcf=x; modcf[modcf>0]=0;
		npvn=-cfnpv(modcf,safe);
		res$mirr=cbind(safe,rein,100*((nfvp/npvn)^(1/(length(x)-1))-1));
		colnames(res$mirr)=c("Safe%","Rein%","MIRR%");
		rownames(res$mirr)=1:nn;
	} else res$mirr=NULL;

	names(x)=1:length(x);
	res$cf=x;
	res$irr=cfirr(x);
	res$ext=cfext(x);

	if (!is.null(i)) {
		for (k in 1:length(i)) {
			tab=rbind(tab,c(i[k],cfnpv(x,i[k]),cfnfv(x,i[k]),cfnus(x,i[k])));
	} 
	rownames(tab)=1:length(i);
	colnames(tab)=c("I%","NPV","NFV","NUS");

	} else tab=NULL;

	res$tab=tab;
	class(res)="cf";
	return(res);

}

"ireff" <-
function (nom,p) 
{
if (p != Inf) {
	return(((1+nom/(100*p))^p-1)*100)
	}
	else
	{
	return ((exp(nom/100)-1)*100)
	}

}

"irnom" <-
function (eff,p) 
{
if (p != Inf) {
	return(10^(2*(p-1)/p)*p*(eff+100)^(1/p)-100*p)
	}
	else
	{
	return (100*log((eff+100)/100))
	}

}

"plot.cf" <-
function (x,type=c("bar","npv"),...) 
{
cfnpv = function (x,i) 
{
        npv = c()       

for (k in 1:length(i)) 
{
        n = length(x)
        j = 0:(n-1)
        pvs = x * sppv(i[k],j)
        npv = c(npv,sum(pvs))
}

return(npv);

}

cfnfv = function (x,i) 
{
        return(cfnpv(x,i)*spfv(i,length(x)-1))
}


cfnus = function (x,i) 
{
        cfnpv(x,i)/uspv(i,length(x)-1);
}


s <- match.arg(type)
pt <- switch(s, bar =0, npv =1)

if (pt==0) {
	if (is.null(x$tab)) r = 1.1*range(c(x$cf,cumsum(x$cf)))
	else r = 1.1*range(c(x$cf,cumsum(x$cf),as.vector(x$tab[,2])))

	p = barplot(x$cf,ylim=r,...);
	lines(p,cumsum(x$cf),type="b");

	if (!is.null(x$tab)) {
		abline(h=as.vector(x$tab[,2]),lty=1:nrow(x$tab));
		axis(4,x$tab[,2],x$tab[,1]);
	}

}
else if (pt==1)
	{cf = x$cf; 
	curve(cfnpv(cf,x),1,100,xlab="i%",ylab="NPV");
	  abline(h=0);
	  abline(v=x$irr,lty=2);
	  axis(3,x$irr,round(x$irr,2));
	  abline(v=x$ext,lty=3);
	  axis(3,x$ext,round(x$ext,2));
	}



}

"plot.tvm" <-
function (x,row=1,...) 
{
	row = x[row,];

	cf = c(row[3],rep(row[5],row[2]),row[4]);
	cf[2]=cf[2]*(1+row[7]);	
	names(cf)=NULL;
	pl = barplot(cf,ylim=1.1*range(c(cf,cumsum(cf))),...);
	lines(pl,cumsum(cf),type="b");

}

"print.cf" <-
function (x,...) 
{

cat("\nCash Flow Model\n\n");

cat("Flows:\n");
print(x$cf);
cat("\n IRR%:",round(x$irr,2),"\n");
cat(" NPV Extremes at I%:",round(x$ext,2),"\n");
if (!is.null(x$mirr)) { cat("\n"); print(round(x$mirr,2)); }
cat("\n");

if (!is.null(x$tab)) { print(round(x$tab,2)); }

}

"print.tvm" <-
function (x,...) 
{

cat("\nTime Value of Money model\n\n");

class(x)=NULL;

print(round(x,2));
cat("\n");

}

"spfv" <-
function (i,n) 
{
	return((1+i/100)^n);
}

"sppv" <-
function (i,n) 
{
	return((1+i/100)^(-n))
}

"summary.cf" <-
function (object,flows=2:length(object$cf),...) 
{
	for (k in flows) {

	cat("\n#",k,"\n");

	print(cf(object$cf[1:k],object$tab[,1]));

	}

}

"summary.tvm" <-
function (object,row=1,...) 
{

cat("\nAmortization Table\n\n");

	x=object;
	row=x[row,];
	n = row[2];  a=row[7];
	i = row[1]/(100*row[8]);
	pv = row[3]; fv = row[4]; pmt=row[5];
	days = row[6]; pyr=row[8];

	bal=pv+a*pmt; 
	res=c()

	for (k in 1:(n-a))
	{
	if (k==1) {
		int = bal*i*(days/(360/pyr));
		prin = pmt+int;
		bal = bal+prin;
		prin = prin+a*pmt;
		res = rbind(res,c(bal,int,prin,pmt*(1+a)));
	}
	else
	{
		int = bal*i;
		prin = pmt+int;
		bal = bal+prin;
		res = rbind(res,c(bal,int,prin,pmt));
	}
	}
	res=rbind(res,c(NA,sum(res[,2]),sum(res[,3]),sum(res[,4])));
	colnames(res)=c("Bal","Int","Prin","PMT");
	rownames(res)=c(1:(n-a),"Total");
	print(round(res,2),na.print="");
	invisible(res);
}

"tvm" <-
function (i = 0,n = 1,pv = 0,fv = 0,pmt = 0,days = 360/pyr,adv = 0,pyr = 12,cyr = pyr) 
{

options(warn=-1);

ii = i;
nn = n;

res =c()

l = max(c(length(i),length(n),length(pv),length(fv),length(pmt),length(days),
length(adv),length(pyr),length(cyr)));

ii = ii+rep(0,l);
nn = nn+rep(0,l);
pv = pv+rep(0,l);
fv = fv+rep(0,l);
pmt = pmt+rep(0,l);
days = days+rep(0,l);
adv = adv+rep(0,l);
pyr = pyr+rep(0,l);
cyr = cyr+rep(0,l);

for (k in 1:l) {

b=pv[k]; p=pmt[k]; f=fv[k]; d=days[k]; 
a=adv[k]; i=ii[k]; n=nn[k]; py=pyr[k]; cy=cyr[k];

if (py!=cy) i = irnom(ireff(i,cy),py);

i=i/(100*py);

s=1;

q=d/(360/py);


if (sum(is.na(c(b,p,f,i,n,a)))!=1)
{  stop("Incorrect number of Not Available values"); }

if (is.na(b)) b = (i + 1)^(-n)*(p*(i + 1)^a*(i*s + 1) - p*(i + 1)^n*(a*i + 1)*(i*s + 1) - f*i)/(i*(i*q + 1));

if (is.na(f)) f = (p*(i + 1)^(2*a)*(i*s + 1) - (i + 1)^(a + n)*(2*a*i*p*(i*s + 1) + b*i*(i*q + 1) + 2*p*(i*s + 1))
  + (i + 1)^(2*n)*(a*i + 1)*(a*i*p*(i*s + 1) + b*i*(i*q + 1) + p*(i*s + 1)))/(i*((i + 1)^a - (i + 1)^n*(a*i + 1)));

if (is.na(p)) p = i*(b*(i + 1)^n*(i*q + 1) + f)/(((i + 1)^a - (i + 1)^n*(a*i + 1))*(i*s + 1));

if (is.na(n)) n = log((p*(i + 1)^a*(i*s + 1) - f*i)/(a*i*p*(i*s + 1) + b*i*(i*q + 1) + p*(i*s + 1)))/log(i + 1)

if (is.na(i)) {
fi = function (i) {
 (- b*(1 + i*q) - f*(1 + i)^(-n))/((1 - (1 + i)^(- (n - a)))/i + a) - p*(1 + i*s)
}
r = try(uniroot(fi,c(1e-10,1/py),tol=1e-10),silent=T);
if (inherits(r,"try-error")) i = NA else i = r$root;

}
if (is.na(a)) {
fa = function (a) {
 (- b*(1 + i*q) - f*(1 + i)^(-n))/((1 - (1 + i)^(- (n - a)))/i + a) - p*(1 + i*s)
}
r = try(uniroot(fa,c(0,n),tol=1e-10),silent=T);
if (inherits(r,"try-error")) a = NA else a = r$root;
}
i=i*py*100;
res=rbind(res,c(i,n,b,f,p,d,a,py,cy));

}

class(res)="tvm";
rownames(res)=1:k;
colnames(res)=c("I%","#N","PV","FV","PMT","Days","#Adv","P/YR","C/YR");
return(res);

}

"update.cf" <-
function (object,flows=NULL,i=NULL,safe=NULL,rein=NULL,...)
{

	if (is.null(flows)) flows=object$cf;
	if (is.null(i)) i=object$tab[,1];
	if (is.null(safe)) safe=object$mirr[,1];
	if (is.null(rein)) rein=object$mirr[,2];

	return(cf(flows,i,safe,rein));

}

"update.tvm" <-
function (object,i = NULL,n = NULL,pv = NULL,fv = NULL,pmt = NULL,days = NULL,adv = NULL,pyr = NULL,cyr = NULL,...) 
{

options(warn=-1);

	x=object;

if (is.null(i)) i = x[,1]
if (is.null(n)) n = x[,2]
if (is.null(pv)) pv = x[,3]
if (is.null(fv)) fv = x[,4]
if (is.null(pmt)) pmt = x[,5]
if (is.null(days)) days = x[,6]
if (is.null(adv)) adv = x[,7]
if (is.null(pyr)) pyr = x[,8]
if (is.null(cyr)) cyr = x[,9]

ii = i;
nn = n;

res =c()

l = max(c(length(i),length(n),length(pv),length(fv),length(pmt),length(days),
length(adv),length(pyr),length(cyr)));

ii = ii+rep(0,l);
nn = nn+rep(0,l);
pv = pv+rep(0,l);
fv = fv+rep(0,l);
pmt = pmt+rep(0,l);
days = days+rep(0,l);
adv = adv+rep(0,l);
pyr = pyr+rep(0,l);
cyr = cyr+rep(0,l);

for (k in 1:l) {

b=pv[k]; p=pmt[k]; f=fv[k]; d=days[k]; 
a=adv[k]; i=ii[k]; n=nn[k]; py=pyr[k]; cy=cyr[k];

if (py!=cy) i = irnom(ireff(i,cy),py);

i=i/(100*py);

s=1;

q=d/(360/py);


if (sum(is.na(c(b,p,f,i,n,a)))!=1)
{  stop("Incorrect number of Not Available values"); }

if (is.na(b)) b = (i + 1)^(-n)*(p*(i + 1)^a*(i*s + 1) - p*(i + 1)^n*(a*i + 1)*(i*s + 1) - f*i)/(i*(i*q + 1));

if (is.na(p)) p = i*(b*(i + 1)^n*(i*q + 1) + f)/(((i + 1)^a - (i + 1)^n*(a*i + 1))*(i*s + 1));

if (is.na(f)) f = (p*(i + 1)^(2*a)*(i*s + 1) - (i + 1)^(a + n)*(2*a*i*p*(i*s + 1) + b*i*(i*q + 1) + 2*p*(i*s + 1))
  + (i + 1)^(2*n)*(a*i + 1)*(a*i*p*(i*s + 1) + b*i*(i*q + 1) + p*(i*s + 1)))/(i*((i + 1)^a - (i + 1)^n*(a*i + 1)));

if (is.na(n)) n = log((p*(i + 1)^a*(i*s + 1) - f*i)/(a*i*p*(i*s + 1) + b*i*(i*q + 1) + p*(i*s + 1)))/log(i + 1)

if (is.na(i)) {
fi = function (i) {
 (- b*(1 + i*q) - f*(1 + i)^(-n))/((1 - (1 + i)^(- (n - a)))/i + a) - p*(1 + i*s)
}
r = try(uniroot(fi,c(1e-10,1/py),tol=1e-10),silent=T);
if (inherits(r,"try-error")) i = NA else i = r$root;

}
if (is.na(a)) {
fa = function (a) {
 (- b*(1 + i*q) - f*(1 + i)^(-n))/((1 - (1 + i)^(- (n - a)))/i + a) - p*(1 + i*s)
}
r = try(uniroot(fa,c(0,n),tol=1e-10),silent=T);
if (inherits(r,"try-error")) a = NA else a = r$root;
}
i=i*py*100;
res=rbind(res,c(i,n,b,f,p,d,a,py,cy));

}

class(res)="tvm";
rownames(res)=1:k;
colnames(res)=c("I%","#N","PV","FV","PMT","Days","#Adv","P/YR","C/YR");
return(res);

}

"usfv" <-
function (i,n) 
{
	return( ((1+i/100)^n-1)/(i/100) )
}

"uspv" <-
function (i,n) 
{
	return((1-(1+i/100)^-n)/(i/100))
}

