Skip to content

How to do a backward calculation for each record in a dataset

13 messages · John Kane, arun, Bert Gunter +3 more

John Kane
# 
This sounds a bit too much like homework.  

And in any case https://github.com/hadley/devtools/wiki/Reproducibility

John Kane
Kingston ON Canada
____________________________________________________________
FREE 3D MARINE AQUARIUM SCREENSAVER - Watch dolphins, sharks & orcas on your desktop!
arun
# 
Hi,
I am? not sure I understand it correctly.

dat1<-read.table(text="
customer.name??? product??? cost
John??? Toothpaste??? 30
Mike??? Toothpaste??? 45
Peter??? Toothpaste??? 40
",sep="",header=TRUE,stringsAsFactors=FALSE)
?dat1$no.of.orders<-? sqrt((dat1$cost-3.40)/1.20)
?dat1
#? customer.name??? product cost no.of.orders
#1????????? John Toothpaste?? 30???? 4.708149
#2????????? Mike Toothpaste?? 45???? 5.887841
#3???????? Peter Toothpaste?? 40???? 5.522681
A.K.





----- Original Message -----
From: Prakasit Singkateera <asltjoey.rsoft at gmail.com>
To: r-help at r-project.org
Cc: 
Sent: Sunday, February 17, 2013 8:10 AM
Subject: [R] How to do a backward calculation for each record in a dataset

Hi Experts,

I have a dataset of 3 columns:

customer.name? ?  product? ?  cost
John? ?  Toothpaste? ?  30
Mike? ?  Toothpaste? ?  45
Peter? ?  Toothpaste? ?  40

And I have a function of cost whereby

cost = 3.40 + (1.20 * no.of.orders^2)

I want to do a backward calculation for each records (each customer) to
find his no.of.orders and create a new column named "no.of.orders" in that
dataset but I don't know how to do.

Please help me.

Thank you everyone,
Prakasit

??? [[alternative HTML version deleted]]

______________________________________________
R-help at r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-help
PLEASE do read the posting guide http://www.R-project.org/posting-guide.html
and provide commented, minimal, self-contained, reproducible code.
Bert Gunter
# 
Homework? We don't do homework here.

-- Bert

On Sun, Feb 17, 2013 at 5:10 AM, Prakasit Singkateera
<asltjoey.rsoft at gmail.com> wrote:

  
    

      
      
    

  


  


      

    

    

      
      

        
      

    

    

      
      

        


  

        

      Berend Hasselman
    

    

      
      #
    

  


  

      
On 18-02-2013, at 10:34, Prakasit Singkateera <asltjoey.rsoft at gmail.com> wrote:

        

            

      
      
      
    

        
You can find R versions of the Excel functions here: http://factbased.blogspot.nl/2013/02/some-of-excel-finance-functions-in-r.html
The R code is here: http://pastebin.com/q7tyiEmM
I do not know if these are a correct translation of what's in Excel or Calc.

For you application to find the number of payments, you can use the R function uniroot for solving a single equation with one unknown.
Small example

# R version of Excel PMT function (as in LibreOffice Calc)
pmt <- function(rate, nper, pv, fv=0, type=0) {
  rr <- 1/(1+rate)^nper
  res <- (-pv-fv*rr)*rate/(1-rr)
  return(res/(1+rate*type))
}

# here x is the number of payments
Rpmt <- function(x, xrate, xpmt, xpv) xpmt - pmt(xrate,x,xpv)

irate <- .05
xpmt <- -10
xpv <- 100

# testing
pmt(irate,10,xpv)
pmt(irate,5,xpv)
pmt(irate,20,xpv)
Rpmt(xpv/xpmt/2,xrate=irate, xpmt=xpmt, xpv=xpv)
Rpmt(xpv/xpmt*2,xrate=irate, xpmt=xpmt, xpv=xpv)

# find number of payments
z <- uniroot(Rpmt,lower=1,upper=100, xrate=irate, xpmt=xpmt, xpv=xpv)  
z
#number of payments 
z$root

# check
Rpmt(z$root,xrate=irate, xpmt=xpmt, xpv=xpv)
pmt(irate,z$root,xpv)
 
Should you desire higher accuracy of the solution, use tol=1e-8 in the uniroot() call.

Berend

  
  


  


      

    

    

      
      

        


  

        

      Rolf Turner
    

    

      
      #
    

  


  

      
Some (quite a few!) years ago I wrote myself a wee function called
compInt() ("compound interest") to do --- I think --- just what you require.
I have attached the code for this function and a help file for it.

If anyone else wants this code, and if the attachments don't get through 
the list,
let me know and I can send the stuff to you directly.

     cheers,

         Rolf Turner

        
On 02/18/2013 10:34 PM, Prakasit Singkateera wrote:

            

      
      
      
    

        
-------------- next part --------------
compInt <- function(P=NULL,r=NULL,n=NULL,a=NULL) {
#
# Function compInt.  To calculate one of the parameters P,r,n,a,
# associated with the compound interest formula,
#
#
#                     12a
#  (1 + r/12)^n = ------------
#                  (12a - rP)
#
# given the other three.
# P = principle, r = annual interest rate (compounded monthly),
# n = number of months until loan is paid off; a = monthly payment.
#

chk <- sum(c(is.null(P),is.null(r),is.null(n),is.null(a)))
if(chk > 1) stop("Must specify either ONE or ZERO non-null arguments.\n")

if(!is.null(P) && (!is.numeric(P) || length(P) != 1 || P <= 0))
	stop("Argument \"P\" must be a positive numeric scalar.\n")
if(!is.null(r) && (!is.numeric(r) || length(r) != 1 || r <= 0))
	stop("Argument \"r\" must be a positive numeric scalar.\n")
if(!is.null(n) && (!is.numeric(n) || length(n) != 1 || n <= 0 ||
                   !isTRUE(all.equal(n,round(n)))))
	stop("Argument \"n\" must be a positive integer scalar.\n")
if(!is.null(a) && (!is.numeric(a) || length(a) != 1 || a <= 0))
	stop("Argument \"a\" must be a positive numeric scalar.\n")

if(chk==0) {
	A <- ((1+r/12)^n)*(P - 12*a/r) + 12*a/r
	A <- max(A,0)
	if(isTRUE(all.equal(A,0))) {
		nlast <- ceiling(Recall(P=P,r=r,a=a))
		attributes(nlast) <- NULL
	} else nlast <- NULL
	A <- c(A=A)
	if(!is.null(nlast)) attr(A,"lastNonZero") <- nlast
	return(A)
}

if(is.null(P))
	return(c(P=(12*a/r)*(1 - (1+r/12)^(-n))))

if(is.null(r)) {
	if(P/a > n) stop("You would need a negative interest rate!\n")
	if(n==1) return(c(r=12*(a-P)/P))
	fff <- function(r,P,n,a) {
		fval <- n*log(1+r/12) + log(12*a-r*P) - log(12*a)
		J    <- n/(12+r) - P/(12*a - r*P)
		list(fval=fval,jacobian=J)
	}
	r1 <- 12*(1+n/P)/(n-1)
	r2 <- 0.99*12*a/P
	rr <- seq(r1,r2,length=100)
	ss <- fff(rr,P,n,a)$fval
	r0 <- rr[which.min(abs(ss))]
	return(c(r=newt(fff,start=r0,P=P,n=n,a=a)))
}

if(is.null(n)) {
	if(r*P >= 12*a) return(Inf)
	n <- (log(12*a) - log(12*a - r*P))/log(1+r/12)
	nl <- floor(n)
	A <- Recall(P,r,nl,a)
	n <- c(n=ceiling(n))
	attr(n,"lastPayment") <- unname(A)
	return(n)
}

if(is.null(a))
	return(c(a=r*P/(12*(1 - (1+r/12)^(-n)))))
}
-------------- next part --------------
\name{compInt}
\alias{compInt}
\title{
Compound Interest
}
\description{
Calculate one of the parameters \code{P}, \code{r}, \code{n},
\code{a}, associated with the compound interest formula, i.e.:
\deqn{(1 + r/12)^n = \frac{12a}{12a -rP}}{(1+r/12)^n = 12a/(12a -rP)}
given the other three. Alternatively calculate the remaining amount
owing, given all four parameters.  In the compound interest formula
\eqn{P} = principle, \eqn{a} = annual interest rate (compounded
monthly), \eqn{n} = number of months until loan is paid off and
\eqn{a} = monthly payment.
}
\usage{
compInt(P = NULL, r = NULL, n = NULL, a = NULL)
}
\arguments{
  \item{P}{
  Positive numeric scalar equal to the principle of the loan.
}
  \item{r}{
  Positive numeric scalar equal to the annual interest rate (given as a
  \emph{fraction} and NOT as a percentage), compounded monthly.
}
  \item{n}{
  Positive integer scalar equal to the number of months until the loan
  is paid off.
}
  \item{a}{
  Positive numeric scalar equal to the amount of the monthly payment.
}
}
\details{
  Either three or four of the four arguments must be specified.  If one
  argument is left unspecified (i.e. left \code{NULL}) then its value
  will be calculated by the function.  If the unspecified argument is \code{n}
  then the returned value has an attribute \code{lastPayment} giving the
  amount of the last payment (which is in general less than \code{a}).

  If all four arguments are specified then the function calculates
  the amount \code{A} remaining to be paid off after \code{n} payments
  have been made.  If \code{A} is zero then the returned value
  has an attribute \code{lastNonZero} which is the payment number
  corresponding to the last non-zero payment.
}
\value{
  A numeric scalar equal to the value of the argument which was
  left \code{NULL}, or if no argument was left \code{NULL}, a numeric
  scalar equal to the amount remaining to be paid off after \code{n}
  payments have been made.  (See \bold{Details}.)
}
\author{Rolf Turner
  \email{r.turner at auckland.ac.nz}
  \url{http://www.math.unb.ca/~rolf}
}
\note{
  The formula was related to me by Ron Sandland, way back in the good
  old days when I was working for D.M.S. Sydney.  I originally coded
  it up in Splus.  Just now (29/October/2011) I dug around in stored
  files, turned up the code, and turned it into an R function.
}

\section{Warnings}{
  The interest rate \code{r} is interpreted as a \emph{fraction}
  and NOT as a percentage.  E.g. if you are thinking of an interest
  rate of 15\% per annum, then \code{r} should be entered as 0.15.

  The monetary values \code{P}, \code{a}, and \code{A}
  returned by the function are \emph{NOT} rounded to the nearest
  \dQuote{cent}, but rather are left with their usual floating
  point representation.
}

\examples{
compInt(P=800,r=0.15,a=40)
compInt(P=800,r=0.15,n=24)
compInt(P=800,n=24,a=40)
compInt(r=0.15,n=24,a=40)
compInt(P=800,r=0.15,n=24,a=40)
compInt(P=800,r=0.15,n=24,a=30)
}
\keyword{ utilities }

  
  


  


      

    

    

      
      

        


  

        

      Berend Hasselman
    

    

      
      #
    

  


  

      
Rolf,

Your attachments got through.
But where is the function newt(?)

Berend

        
On 18-02-2013, at 21:25, Rolf Turner <rolf.turner at xtra.co.nz> wrote:

        

            

      
      
      
    

        

      
      
    

  
  


  


      

    

    

      
      

        


  

        

      Rolf Turner
    

    

      
      #
    

  


  

      
On 02/19/2013 09:44 AM, Berend Hasselman wrote:

            

      
      
      
    

        
Ahhhh --- dang!  It's another item from my "personal miscellany package"
which I'm so used to having around that I forgot that other people don't 
have it.
Attached.   Along with its documentation file.

Thanks for pointing out my sin of omission. :-)

     cheers,

         Rolf
-------------- next part --------------
newt <- function(fn,start,...,eps.p = 1e-08,eps.v = NULL,
                 maxit = 50,verb = FALSE)
{
p.o <- start
itno <- 1
repeat {
	fj <- fn(p.o,...)
	v <- fj$fval
	t1 <- if(is.null(eps.v)) NULL else sum(abs(v))
	J <- as.matrix(fj$jacobian)
	if(qr(J)$rank < ncol(J)) {
		cat("Singular Jacobian.\n")
		rslt <- if(is.null(eps.v)) NA else if(t1 < eps.v) p.o
		else NA
		break
	}
	else {
		p.n <- p.o - solve(J) %*% v
		t2 <- max(abs(p.n - p.o))
		if(verb) {
			tmp <- format(round(c(p.o,p.n,v,t2,t1),6))
			np <- length(v)
			v1 <- paste(tmp[1:np],collapse = "  ")
			v2 <- paste(tmp[(np + 1):(2 * np)],collapse = "  ")
			v3 <- paste(tmp[(2 * np + 1):(3 * np)],collapse = "  ")
			v4 <- tmp[3 * np + 1]
			v5 <- tmp[3 * np + 2]
			cat("\nIteration  : ",itno,"\n",sep = "")
			cat("Old par    : ",v1,"\n",sep = "")
			cat("New par    : ",v2,"\n",sep = "")
			cat("Test ch.par: ",v4,"\n",sep = "")
			cat("Fn. vals.  : ",v3,"\n",sep = "")
			if(!is.null(t1))
			  cat("Test f.val: ",v5,"\n",sep = "")
		}
		if((!is.null(t1) && t1 < eps.v) | t2 < eps.p) {
			rslt <- p.n
			break
		}
		itno <- itno + 1
		if(itno > maxit) {
			cat("Newton's method failed to converge in\n")
			cat(maxit,"iterations.\n")
			rslt <- NA
			break
		}
		p.o <- p.n
	}
}
as.vector(rslt)
}
-------------- next part --------------
\name{newt}
\alias{newt}
\title{
Newton's method.
}
\description{
A rather naive general implementation of Newton's method;
but it seems to work.  A lot of the time! [ :-) ]
}
\usage{
newt(fn, start, \dots, eps.p=1e-08, eps.v=NULL,
     maxit=50, verb=FALSE)
}
\arguments{
\item{fn}{
A user-supplied function providing the essential information about
the system of equations to be solved.  The system is assumed to be of
the form \eqn{f(x) = 0} where \eqn{f(x)} is a \eqn{k}-dimensional
function (with components \eqn{f_1(x) \ldots f_k(x)}{f_1(x) ...
f_k(x)} of \eqn{k} variables.

The function \code{fn} must be coded to return a list with components
\code{fval} and \code{jacobian}.  The component \code{fval} must be a
\eqn{k}-dimensional vector (whose \eqn{i^{th}}{i-th} component is the
value of \eqn{f_i(x)}.  The component "jacobian" is the Jacobian of
the function \eqn{f}, i.e. it is a matrix whose
\eqn{(i,j)^{th}}{(i,j)-th} entry is the derivative of \eqn{f_i(x)}
with respect to \eqn{x_j}.
}
\item{start}{
A \eqn{k}-dimensional vector of starting values from which to
iterate toward the solution.
}
\item{...}{
Any auxilliary arguments needed by the function \code{fn}.
}
\item{eps.p}{
The iteration stops if the maximum absolute value of the
change in the parameters \eqn{x_1, \ldots, x_k}{x_1, ..., x_k}
is less than \code{eps.p}.
}
\item{eps.v}{
If this argument is provided the iteration stops if the sum of the
absolute values of the function values \eqn{f_j(x)} is less than
\code{eps.v}.  (Note: If \code{eps.v} is provided then iteration will
cease if EITHER the "\code{eps.p} criterion" or the "\code{eps.v}
criterion" is met.)
}
\item{maxit}{
The maximum number of iterations to attempt before giving
up in disgust.
}
\item{verb}{
Logical scalar; if TRUE a description of the current state
of play is printed out at every iteration.
}}
\value{
If the iterative procedure has converged, to within the specified
tolerance(s), the final value of the k-dimensional vector of
parameter ("x") values.  Otherwise, NA.
}
\details{
If the Jacobian becomes (numerically) singular (as determined by the
qv() function) then the function \code{newt} exits.  If \code{eps.v}
is not provided a value of NA is returned.  If \code{eps.v} IS
provided, and if by some miracle the sum of the absolute values of
the function values \eqn{f_j(x)} is less than \code{eps.v}, then the
current value of \eqn{x} is returned (since this \eqn{x} does satisfy
the set of equations to the specified tolerance).
}
\author{Rolf Turner
  \email{r.turner at auckland.ac.nz}
  \url{http://www.math.unb.ca/~rolf}
}
\examples{
foo <- function(x) {
   fval <- c(x[1]**2 + x[2]**2 - 1, x[2] - x[1])
   jacobian <- matrix(c(2*x[1],2*x[2], -1, 1),byrow=TRUE,ncol=2)
   list(fval=fval,jacobian=jacobian)
}
newt(foo,c(0.5,0.5))   # gives (1/sqrt(2),1/sqrt(2))
newt(foo,c(-0.5,-0.5)) # gives (-1/sqrt(2),-1/sqrt(2))
newt(foo,c(-0.5,0.5))  # Singular Jacobian; NA returned.
newt(foo,c(-0.7,0.5))  # gives (-1/sqrt(2),-1/sqrt(2))
}
\keyword{math}

  
  


  


      

    

    

      
      

        
      

    

    

      
      

        
      

    

    

      
      

        


  

        

      Berend Hasselman
    

    

      
      #
    

  


  

      
On 19-02-2013, at 09:55, Prakasit Singkateera <asltjoey.rsoft at gmail.com> wrote:

        

            

      
      
      
    

        
1. You don't need rootSolve. uniroot is sufficient in your case. You don't have multiple roots for each element of cost.

2. You are now storing more information than you require into the resulting dataframe. Use uniroot(?)$root to store only the root of the equation.

3. you don't need plyr. You can do it like this

mysolution <- within(mydata, 
    no.of.orders <- sapply(seq_len(length(cost)),function(k) uniroot(f.to.findroot,interval = c(0,1000),fcost=cost[k])$root )
)
# for printing the dataframe

mysolution

Berend