version 1.1.0

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: pricelevels
 Type: Package
 Title: Spatial Price Level Comparisons
-Version: 1.0.2
+Version: 1.1.0
 Authors@R: person("Sebastian", "Weinand", role=c("aut", "cre"), email="s.weinand90@googlemail.com")
 Description: Price comparisons within or between countries provide an overall measure of the relative difference in prices, often denoted as price levels. This package provides index number methods for such price comparisons (e.g., The World Bank, 2011, <doi:10.1596/978-0-8213-9728-2>). Moreover, it contains functions for sampling and characterizing price data.
 License: EUPL
@@ -14,8 +14,8 @@ VignetteBuilder: knitr
 URL: https://github.com/sweinand/pricelevels
 BugReports: https://github.com/sweinand/pricelevels/issues
 NeedsCompilation: no
-Packaged: 2024-02-07 09:02:19 UTC; Sebastian
+Packaged: 2024-03-26 14:24:57 UTC; Sebastian
 Author: Sebastian Weinand [aut, cre]
 Maintainer: Sebastian Weinand <s.weinand90@googlemail.com>
 Repository: CRAN
-Date/Publication: 2024-02-08 21:10:02 UTC
+Date/Publication: 2024-03-26 14:40:03 UTC

MD5

@@ -1,42 +1,45 @@
-c4bd0246692c2a7b48daea2ce7f06287 *DESCRIPTION
-bd89347943ea87e95f439a13a5cfc1e7 *NAMESPACE
-12638734f39097b2d7ba4c12acf036f6 *NEWS.md
+abdb3ad6cb478cc79e767c97bca88242 *DESCRIPTION
+66421f0c77bb41bceefae82e8fd4fb16 *NAMESPACE
+f1513cac7c5ce0a4e00725bfdf228a0d *NEWS.md
 4e7b9ebc47389fbe61533471b12cb166 *R/bilateral.index.r
-14b1e925a8c0511943907afe38d7dc22 *R/cpd.R
-133c70c810799ae04dac2b0eb370c232 *R/geks.R
-2fafa91e59b92de2ceb62a5c8a398ff2 *R/gkhamis.r
+1bc9d26c01342d21f1550237ae1e6054 *R/cpd.R
+b061c70156888e324991c6c45dea3636 *R/geks.R
+41b65e9e7e3dfd7ce5080e9937087c91 *R/gerardi.r
+4f15d2ed6476cabf9be61924791ba4c8 *R/gkhamis.r
 f5c7ef7df02639555e3634ff96bea8c2 *R/globals.r
-65880631d490124e4bded7a6d7c4e559 *R/helper.r
+96545a1cc1078ee4bd693ef5bd7d8ae4 *R/helper.r
 57cafabc31e26204d8160408faf8a395 *R/input_checks.R
 326374f387613699ce88e0b034abf3af *R/neighbors.R
-15f3cf8ef7e37f5c7a683f9eca64f9ca *R/pricelevels.R
+153dcfb30297a0526d4d0e0d195dbab8 *R/pricelevels.R
 201c2f7fa231c9be9b3b51b0ea71f53a *R/ratios.R
 45c77113c729da0b433464b019ed8a2d *R/rdata.R
-4a5518728b1cf6f9f45f9eece480c2dc *R/sysdata.rda
-a01342973d02a74bb95fe4cf2f5cbfa3 *README.md
+df2d5e4148740c0d825622697e8fa520 *R/sysdata.rda
+79120299e9cfa426db80a8186e35a2f9 *README.md
 49f506a35a9351dc871011f82d201bf1 *build/vignette.rds
-4de45fd2a2f5728dd6d36c80255343fb *inst/doc/pricelevels-intro.R
-f0ee58ea94fd50221bcb82acd3cb85cc *inst/doc/pricelevels-intro.Rmd
-b773914fec1849dc42ffbfd6355421d9 *inst/doc/pricelevels-intro.html
+8b93713001c870bccc1b42e00fd63e19 *inst/doc/pricelevels-intro.R
+96ce9aa1f7adbc250165866ed3b2037c *inst/doc/pricelevels-intro.Rmd
+64dbc1040d2fb6817ee68e5c66be21b6 *inst/doc/pricelevels-intro.html
 19eead10912d82afed96061049572f3e *man/bilateral.index.Rd
-f65a28a6147f4a8149279d167478325b *man/cpd.Rd
+81ec93b6694573c2c8f244e487869194 *man/cpd.Rd
 88083ef4f9726ff6fc034d798b7a242b *man/geks.Rd
-2c4440bcb411a6c92a599093966cb59f *man/gkhamis.Rd
+9301ed076acfc2cf4c1496a4b45908a7 *man/gerardi.Rd
+3f7d0a24298c94e5cccc4d672ff8a6fa *man/gkhamis.Rd
 6e911d77d0936ab729a17a5ffd82b9cb *man/neighbors.Rd
 bf809618f445a3f432beb5faa242f277 *man/pricelevels.Rd
 fa29365b9d979363bee1555594d7317d *man/ratios.Rd
 4040f88fc559068d32bd91ec152f0165 *man/rdata.Rd
 203c20a79f0c85268039b95e90e4dfb3 *tests/testthat.R
-3443710c31ed06e032fcd2e24fd28292 *tests/testthat/test-bilateral.index.R
-5a0e1a9a7460c37316365cf354d8f704 *tests/testthat/test-cpd.R
-b31e4277ebba865396cb44f7cefc50ce *tests/testthat/test-geks.R
-100c06463c2bdff0e7b0f0715617756e *tests/testthat/test-gkhamis.R
+f3f410c7aaa956ac6c72f545d58dc208 *tests/testthat/test-bilateral.index.R
+cd3278fa6818c36aa7637480cd81b960 *tests/testthat/test-cpd.R
+24a8635ee27a4ab165265ffb5d39627e *tests/testthat/test-geks.R
+d57152753709328abb87c52856863949 *tests/testthat/test-gerardi.R
+23589249b58563db253b374d8d785688 *tests/testthat/test-gkhamis.R
 a8b55ca23bfa2870d6ce675f8f3a333f *tests/testthat/test-helper.r
 c78124504c7d0facfdda66cf112110a4 *tests/testthat/test-input_checks.R
 da55f43f32229a46a34cadf4182eec0a *tests/testthat/test-neighbors.R
 f938d17f00f207d71462e309ec9d791c *tests/testthat/test-pricelevels.R
 6ab5202497fe50630099da1466f32a06 *tests/testthat/test-ratios.R
 6b885cea4de019c45381664b7e6ee310 *tests/testthat/test-rdata.R
-f0ee58ea94fd50221bcb82acd3cb85cc *vignettes/pricelevels-intro.Rmd
+96ce9aa1f7adbc250165866ed3b2037c *vignettes/pricelevels-intro.Rmd
 b76e42c05a983a023c7b1566acb6166a *vignettes/references.bib
 b76e42c05a983a023c7b1566acb6166a *vignettes/references.bib.sav

NAMESPACE

@@ -16,21 +16,26 @@ export(geowalsh)
 export(gerardi)
 export(gkhamis)
 export(harmonic)
-export(idb)
+export(ikle)
 export(index.pairs)
 export(is.connected)
 export(jevons)
 export(laspeyres)
 export(lehr)
 export(lowe)
 export(list.indices)
+export(mjevons)
+export(mdutot)
+export(mharmonic)
+export(mcarli)
 export(medgeworth)
 export(neighbors)
 export(nlcpd)
 export(paasche)
 export(palgrave)
 export(pricelevels)
 export(rao)
+export(rhajargasht)
 export(ratios)
 export(rdata)
 export(rgaps)

NEWS.md

@@ -1,6 +1,16 @@
+# pricelevels 1.1.0
+
+* New functions `mjevons()`, `mcarli()`, `mdutot()`, and `mharmonic()`
+* In `nlcpd()`, introduced matching of lower and upper bounds and replaced argument `par.start` with the default `par`
+* Separated the `gerardi()` index from the iterative ones
+* Duplicated prices are aggregated now as weighted averages instead of unweighted ones in the helper function `arrange()`
+* Updated the package vignette
+* Updated tests
+
 # pricelevels 1.0.2
 
 In the DESCRIPTION file:
+
 * Updated the package description
 * Added a reference to the World Bank's methodological manual 
 * Included the Authors@R field

R/cpd.R

@@ -2,7 +2,7 @@
 
 # Title:  Linear and nonlinear CPD regression
 # Author: Sebastian Weinand
-# Date:   5 February 2024
+# Date:   16 March 2024
 
 # CPD method:
 cpd <- function(p, r, n, q=NULL, w=NULL, base=NULL, simplify=TRUE, settings=list()){
@@ -193,42 +193,30 @@ nlcpd_self_start <- function(p, r, n, w, w.delta, base=NULL, strategy="s1"){
 }
 
 # non-exported helper function to check NLCPD parameter start values:
-nlcpd_start_check <- function(x, r, n, len=NULL){
+nlcpd_set_start <- function(x, r, n, base=NULL){
 
   input <- deparse(substitute(x))
   msg_prefix <- paste("Non-valid input for", input, "->")
   n <- factor(n)
   r <- factor(r)
 
-  # check list:
-  if(!is.list(x)) stop(paste(msg_prefix, "must be a list"), call. = FALSE)
-  if(length(x) != 3L) stop(paste(msg_prefix, "must be of length 3L"), call. = FALSE)
-  if(!all(c("lnP","pi","delta") %in% names(x))) stop(paste(msg_prefix, "list names must be 'lnP', 'pi', 'delta'"), call. = FALSE)
-
-  # check elements:
-  if(length(x$lnP)>0) check.num(x=x$lnP, min.len=0, max.len=Inf, miss.ok=FALSE, null.ok=FALSE, na.ok=FALSE, int=c(-Inf,Inf))
-  if(length(x$pi)>0) check.num(x=x$pi, min.len=0, max.len=Inf, miss.ok=FALSE, null.ok=FALSE, na.ok=FALSE, int=c(-Inf,Inf))
-  if(length(x$delta)>0) check.num(x=x$delta, min.len=0, max.len=Inf, miss.ok=FALSE, null.ok=FALSE, na.ok=FALSE, int=c(-Inf,Inf))
-
-  # check element names:
-  if(is.null(names(x$lnP))) stop(paste(msg_prefix, "'lnP' must have names"), call. = FALSE)
-  if(is.null(names(x$pi))) stop(paste(msg_prefix, "'pi' must have names"), call. = FALSE)
-  if(is.null(names(x$delta))) stop(paste(msg_prefix, "'delta' must have names"), call. = FALSE)
-
-  # subset to matches:
-  x$lnP <- x$lnP[names(x$lnP)%in%levels(r)]
-  x$pi <- x$pi[names(x$pi)%in%levels(n)]
-  x$delta <- x$delta[names(x$delta)%in%levels(n)]
-
-  # check matching lengths:
-  if(length(x$lnP)<len[["lnP"]]) stop(paste(msg_prefix, "'names(par.start$lnP) %in% levels(r)' must be of length greater or equal to", len[["lnP"]]), call.=FALSE)
-  if(length(x$pi)<len[["pi"]]) stop(paste(msg_prefix, "'names(par.start$pi) %in% levels(n)' must be of length greater or equal to", len[["pi"]]), call.=FALSE)
-  if(length(x$delta)<len[["delta"]]) stop(paste(msg_prefix, "'names(par.start$delta) %in% levels(n)' must be of length greater or equal to", len[["delta"]]), call.=FALSE)
-
-  # subset to required lengths:
-  x$lnP <- x$lnP[1:len[["lnP"]]]
-  x$pi <- x$pi[1:len[["pi"]]]
-  x$delta <- x$delta[1:len[["delta"]]]
+  # check input:
+  if(!is.vector(x)) stop(paste(msg_prefix, "must be a named vector"), call. = FALSE)
+  if(is.null(names(x))) stop(paste(msg_prefix, "must be a named vector"), call. = FALSE)
+  check.num(x=x, min.len=1, max.len=Inf, miss.ok=FALSE, null.ok=FALSE, na.ok=FALSE, int=c(-Inf,Inf))
+
+  # set order and names of start parameters:
+  par.order <- c(
+    paste0("pi.", levels(n)),
+    paste0("lnP.", if(is.null(base)){levels(r)[-nlevels(r)]}else{levels(r)[-1]}),
+    if(nlevels(n)>1) paste0("delta.", levels(n)[-1]))
+  # order important if use.jac=TRUE!
+
+  # match start parameters to expected ones:
+  x <- x[match(x=par.order, table=names(x))]
+  if(any(is.na(x))){
+    stop("Non-valid input for 'par' -> not all required parameters provided")
+  }
 
   # return output:
   return(x)
@@ -387,7 +375,6 @@ nlcpd <- function(p, r, n, q=NULL, w=NULL, base=NULL, simplify=TRUE, settings=li
   if(is.null(settings$connect)) settings$connect <- TRUE
   if(is.null(settings$chatty)) settings$chatty <- TRUE
   if(is.null(settings$use.jac)) settings$use.jac <- FALSE
-  if(is.null(settings$par.start)) settings$par.start <- NULL
   if(is.null(settings$self.start)) settings$self.start <- "s1"
   if(is.null(settings$w.delta)) settings$w.delta <- NULL
 
@@ -418,14 +405,15 @@ nlcpd <- function(p, r, n, q=NULL, w=NULL, base=NULL, simplify=TRUE, settings=li
     check.log(x=settings$chatty, min.len=1, max.len=1, na.ok=FALSE)
     check.log(x=settings$use.jac, min.len=1, max.len=1, na.ok=FALSE)
     check.char(x=settings$self.start, min.len=1, max.len=1, na.ok=FALSE)
-    # settings$w.delta and settings$par.start are checked later
+    # settings$w.delta is checked later
 
   }
 
   # overwrite defaults by ellipsis elements:
   defaults <- formals(minpack.lm::nls.lm)
   dots <- list(...)
   defaults[names(dots)] <- dots
+  if(length(defaults$par)<=1 && defaults$par=="") defaults$par <- NULL
 
   # residual function to be minimzed:
   resid_fun <- function(par, p, r, n, w, w.delta, base=NULL){
@@ -473,35 +461,42 @@ nlcpd <- function(p, r, n, q=NULL, w=NULL, base=NULL, simplify=TRUE, settings=li
     # number of products
     N <- nlevels(pdata$n)
 
-    # set delta weights if missing:
-    if(is.null(settings$w.delta)){
-      w.delta <- pdata[, tapply(X=w, INDEX=n, FUN=mean)]
-      w.delta <- w.delta/sum(w.delta) # normalisation of weights
-    }else{
-      if(is.null(names(settings$w.delta))) stop("Non-valid input for 'settings$w.delta' -> vector must have names")
-      if(!all(levels(pdata$n)%in%names(settings$w.delta), na.rm=TRUE)) stop("Non-valid input for 'settings$w.delta' -> weights for all products 'levels(n)' required")
-      if(abs(sum(settings$w.delta)-1)>1e-5 && settings$chatty) warning("Sum of 'settings$w.delta' not 1")
-      w.delta <- settings$w.delta
+    # delta weights:
+    w.delta <- settings$w.delta[match(x=levels(pdata$n), table=names(settings$w.delta))]
+    if(any(is.na(w.delta)) && settings$chatty){
+      warning("Not all values in 'settings$w.delta' matched to 'levels(n)' -> reset to 'settings$w.delta=NULL'")
+      w.delta <- NULL
     }
+    if(is.null(w.delta)) w.delta <- pdata[, tapply(X=w, INDEX=n, FUN=mean)]
+    w.delta <- w.delta/sum(w.delta) # normalisation of weights
 
-    # set start parameters if not given by user:
-    if(is.null(settings$par.start)){
+    # parameter start values:
+    if(is.null(defaults$par)){
       settings$self.start <- match.arg(arg=settings$self.start, choices=paste0("s", 1:3))
-      start <- with(pdata, nlcpd_self_start(p=p, r=r, n=n, w=w, w.delta=w.delta, base=base, strategy=settings$self.start))
-    }else{
-      start <- with(pdata, nlcpd_start_check(x=settings$par.start, r=r, n=n, len=c("lnP"=R-1, "pi"=N, "delta"=N-1)))
+      defaults$par <- with(pdata, nlcpd_self_start(p=p, r=r, n=n, w=w, w.delta=w.delta, base=base, strategy=settings$self.start))
     }
 
-    # # input checks on start:
-    # check.nlcpd.start(x=start, r=pdata$r, n=pdata$n, min.len=c("lnP"=R-1, "pi"=N, "delta"=N-1))
+    # check and set parameter start values:
+    par.start <- unlist(x=defaults$par, use.names=TRUE)
+    par.start <- with(pdata, nlcpd_set_start(x=par.start, r=r, n=n, base=base))
 
-    # reorder start parameters:
-    start <- start[c("pi", "lnP", "delta")] # important if use.jac=TRUE
-    par.start <- unlist(start, use.names=TRUE)
+    # match ordering of lower bounds to start parameters:
+    if(!is.null(defaults$lower)){
+      defaults$lower <- defaults$lower[match(x=names(par.start), table=names(defaults$lower))]
+      # if(any(is.na(defaults$lower)) & settings$chatty) warning("No lower bounds used for some parameters")
+      defaults$lower[is.na(defaults$lower)] <- -Inf
+    }
+
+    # match ordering of lower bounds to start parameters:
+    if(!is.null(defaults$upper)){
+      defaults$upper <- defaults$upper[match(x=names(par.start), table=names(defaults$upper))]
+      # if(any(is.na(defaults$upper)) & settings$chatty) warning("No upper bounds used for some parameters")
+      defaults$upper[is.na(defaults$upper)] <- Inf
+    }
 
     # set lower and/or upper bounds on delta parameter
     # for products with only one observations. with
-    # one observations only, delta can not be estimated
+    # one observation only, delta can not be estimated
     # properly and estimated price levels will no longer
     # be transitive:
     if(any(nfreq<=1, na.rm=TRUE)){

R/geks.R

@@ -2,7 +2,7 @@
 
 # Title:  Bilateral index pairs and GEKS method
 # Author: Sebastian Weinand
-# Date:   5 February 2024
+# Date:   14 March 2024
 
 # compute bilateral index pairs:
 index.pairs <- function(p, r, n, q=NULL, w=NULL, settings=list()){
@@ -291,7 +291,7 @@ geks.main <- function(p, r, n, q=NULL, w=NULL, base=NULL, simplify=TRUE, setting
     # compute model matrix:
     lnP <- stats::model.matrix(~r, xlev=r.lvl.all)-stats::model.matrix(~rb, xlev=r.lvl.all)
     colnames(lnP) <- sub(pattern="^r", replacement="", x=colnames(lnP))
-    lnP <- lnP[,-1]
+    lnP <- lnP[,-1, drop=FALSE]
 
     # GEKS regression formula:
     geks_mod <- log(index) ~ lnP - 1
@@ -306,6 +306,7 @@ geks.main <- function(p, r, n, q=NULL, w=NULL, base=NULL, simplify=TRUE, setting
 
     # extract estimated regional price levels:
     out <- as.matrix(stats::coef(geks_reg_out))
+    if(nlevels(r)>1 && ncol(lnP)<=1) rownames(out) <- paste0("lnP", colnames(lnP))
     rownames(out) <- gsub(pattern="^lnP", replacement="", x=rownames(out))
 
     # add price level of base region: