version 0.8

cran · Sep 13, 2009 · 26304c9 · 26304c9
1 parent 443e3c0
commit 26304c9
Show file tree

Hide file tree

Showing 4 changed files with 44 additions and 43 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,18 +1,18 @@
 Package: StatMatch
 Type: Package
 Title: Statistical Matching
-Version: 0.7
-Date: 2009-06-18
+Version: 0.8
+Date: 2009-09-11
 Author: Marcello D'Orazio
 Maintainer: Marcello D'Orazio <madorazi@istat.it>
 Depends: R (>= 2.7.0), proxy, lpSolve
 Suggests: optmatch
 Description: This package provides some R functions to perform
-        statistical matching between two data sources. These functions
-        can also be used to impute missing values in data sets through
-        hot-deck methods.
+        statistical matching between two data sources sharing a number
+        of common variables. These functions can also be used to impute
+        missing values in data sets through hot-deck methods.
 License: GPL (>= 2)
 LazyLoad: no
-Packaged: 2009-06-18 15:34:58 UTC; marcello
+Packaged: 2009-09-12 17:33:20 UTC; marcello
 Repository: CRAN
-Date/Publication: 2009-06-18 16:37:17
+Date/Publication: 2009-09-13 09:08:37
diff --git a/R/NND.hotdeck.R b/R/NND.hotdeck.R
@@ -1,7 +1,8 @@
 `NND.hotdeck` <-
 function (data.rec, data.don, match.vars, don.class=NULL, dist.fun="Euclidean", constrained=FALSE, constr.alg=NULL) 
 {
-	if(dist.fun!="Gower" || dist.fun!="exact" || dist.fun!="exact matching"){
+
+    if(dist.fun!="Gower" || dist.fun!="gower" || dist.fun!="exact" || dist.fun!="exact matching"){
 		require(proxy)
 	}
 	if(constrained && constr.alg=="relax"){
@@ -40,16 +41,16 @@ function (data.rec, data.don, match.vars, don.class=NULL, dist.fun="Euclidean",
 ########################
 NND.hd <- function (rec, don, dfun="Euclidean", constr=FALSE, c.alg=NULL)
 { 
-  if(is.null(dim(rec))) x.rec <- data.frame(rec)
+    if(is.null(dim(rec))) x.rec <- data.frame(rec)
 	else x.rec <- rec
-  if(is.null(dim(don))) x.don <- data.frame(don)
+    if(is.null(dim(don))) x.don <- data.frame(don)
 	else x.don <- don
-  p <- ncol(rec)
+    p <- ncol(rec)
 	nr <- nrow(x.rec)
 	nd <- nrow(x.don)
 	if(nr>nd) cat("Warning: the no. do donors is less than the no.f recipients", fill=TRUE)
 
-  r.lab <- rownames(x.rec)
+    r.lab <- rownames(x.rec)
 	if(is.null(r.lab)) r.lab <- 1:nr
 	d.lab <- rownames(x.don)
 	if(is.null(d.lab)) d.lab <- 1:nd
@@ -59,10 +60,10 @@ NND.hd <- function (rec, don, dfun="Euclidean", constr=FALSE, c.alg=NULL)
 
 	if(dfun=="Euclidean" || dfun=="Manhattan"){
 		cat("Warning:", dfun, "distance is being used", fill=TRUE)
-    cat("Warning: all the categorical variables in rec and don data.frame are recoded into dummies", fill=TRUE)
-    x.rec <- fact2dummy(x.rec, all=FALSE)
-    x.don <- fact2dummy(x.don, all=FALSE)
-    mdist <- dist(x=x.rec, y=x.don, method=dfun)
+        cat("Warning: all the categorical variables in rec and don data.frame are recoded into dummies", fill=TRUE)
+        x.rec <- fact2dummy(x.rec, all=FALSE)
+        x.don <- fact2dummy(x.don, all=FALSE)
+        mdist <- dist(x=x.rec, y=x.don, method=dfun)
 	}
 	else if(dfun=="exact" || dfun=="exact matching"){
 		cat("Warning: exact matching distance is being used", fill=TRUE)
@@ -76,9 +77,9 @@ NND.hd <- function (rec, don, dfun="Euclidean", constr=FALSE, c.alg=NULL)
 		xx <- data.frame(rbind(x.rec, x.don))
 		x.rec <- xx[1:nr,]
 		x.don <- xx[-(1:nr),]
-		mdist <- dist(data.x=x.rec, data.y=x.don, method="Gower")
+		mdist <- gower.dist(data.x=x.rec, data.y=x.don)
 	}
-	else if(dfun=="Gower"){
+	else if(dfun=="Gower" || dfun=="gower"){
 		# if(p==1 && is.factor(x.rec)) x.rec <- list(x.rec)
 		# if(p==1 && is.factor(x.don)) x.don <- list(x.don)
 		mdist <- gower.dist(data.x=x.rec, data.y=x.don)
@@ -190,18 +191,18 @@ NND.hd <- function (rec, don, dfun="Euclidean", constr=FALSE, c.alg=NULL)
 		if(!identical(names(l.rec), names(l.don)))
 			cat("Warning: the donation classes seem built using different factors with differnt levels")
 		if(p==1){
-      nn.r <- unlist(lapply(l.rec, length))
-		  nn.d <- unlist(lapply(l.don, length))
-    }
+            nn.r <- unlist(lapply(l.rec, length))
+            nn.d <- unlist(lapply(l.don, length))
+        }
 		else {
-      nn.r <- unlist(lapply(l.rec, nrow))
-      nn.d <- unlist(lapply(l.don, nrow))
-	  }
-    l.rec <- l.rec[nn.r>0]
-    l.don <- l.don[nn.r>0]
-    nn.r <- nn.r[nn.r>0]
-    nn.d <- nn.d[nn.r>0]
-    if(any(nn.d==0)) {
+            nn.r <- unlist(lapply(l.rec, nrow))
+            nn.d <- unlist(lapply(l.don, nrow))
+        }
+        l.rec <- l.rec[nn.r>0]
+        l.don <- l.don[nn.r>0]
+        nn.r <- nn.r[nn.r>0]
+        nn.d <- nn.d[nn.r>0]
+        if(any(nn.d==0)) {
 			stop("For some donation classes there are NO donors available. Please modify the definition of the donation classes")
 		}	
 		H <- length(l.rec)
@@ -214,7 +215,7 @@ NND.hd <- function (rec, don, dfun="Euclidean", constr=FALSE, c.alg=NULL)
 			  dist.rd[[h]] <- out$dist.rd
 			  if(!constrained) noad[[h]] <- out$noad
 		}
-    mmm <- unlist(lapply(mtc.ids, t))
+        mmm <- unlist(lapply(mtc.ids, t))
 		mmm <- substring(mmm, 5)
 		mtc.ids <- matrix(mmm, ncol=2, byrow=TRUE)
 		if(is.null(rownames(data.rec)) && is.null(rownames(data.don)))  mtc.ids <- matrix(as.numeric(mmm), ncol=2, byrow=TRUE)

diff --git a/R/RANDwNND.hotdeck.R b/R/RANDwNND.hotdeck.R
@@ -1,7 +1,7 @@
 `RANDwNND.hotdeck` <-
 function (data.rec, data.don, match.vars=NULL, don.class=NULL, dist.fun="Euclidean", cut.don="rot", k=NULL) 
 {
-	if(dist.fun!="Gower" || dist.fun!="exact" || dist.fun!="exact matching"){
+	if(dist.fun!="gower" || dist.fun!="Gower" || dist.fun!="exact" || dist.fun!="exact matching"){
 		require(proxy)
 	}
 
@@ -72,9 +72,9 @@ RANDwNND.hd <- function (rec, don, dfun="Euclidean", cut.don="rot", k=NULL)
         xx <- data.frame(rbind(x.rec, x.don))
 		    x.rec <- xx[1:nr,]
 		    x.don <- xx[-(1:nr),]
-		    mdist <- dist(data.x=x.rec, data.y=x.don, method="Gower")
+		    mdist <- gower.dist(data.x=x.rec, data.y=x.don)
     }
-    else if(dfun=="Gower"){
+    else if(dfun=="Gower" || dfun=="gower"){
         # if(p==1 && is.factor(x.rec)) x.rec <- list(x.rec)
         # if(p==1 && is.factor(x.don)) x.don <- list(x.don)
         mdist <- gower.dist(data.x=x.rec, data.y=x.don)
@@ -99,24 +99,24 @@ RANDwNND.hd <- function (rec, don, dfun="Euclidean", cut.don="rot", k=NULL)
     }
 
     min.d <- numeric(nr)
-	  max.d <- numeric(nr)
+    max.d <- numeric(nr)
     sd.d <- numeric(nr)
     cut.d <- numeric(nr)
     dist.rd <- numeric(nr)
     nad <- rep(NA, nr)
 
     don.lab <- numeric(nr)
-	  for(i in 1:nr){
-		    vd <- mdist[i,]
+	for(i in 1:nr){
+        vd <- mdist[i,]
         min.dist <- min(vd, na.rm=TRUE) # smallest distance recipient-donor
         min.d[i] <- min.dist
         max.d[i] <- max(vd, na.rm=TRUE)
-		    sd.d[i] <- sd(vd, na.rm=TRUE)
+		sd.d[i] <- sd(vd, na.rm=TRUE)
         if(cut.don=="min"){
-        short.vd <- vd[(vd==min.dist) & !is.na(vd)]
-        appo <- d.lab[(vd==min.dist) & !is.na(vd)]
-        dist.rd[i] <- min.dist
-        cut.d[i] <- min.dist
+            short.vd <- vd[(vd==min.dist) & !is.na(vd)]
+            appo <- d.lab[(vd==min.dist) & !is.na(vd)]
+            dist.rd[i] <- min.dist
+            cut.d[i] <- min.dist
 		}	
         else if(cut.don=="k.dist"){
 			if(k<min.dist) {

diff --git a/man/create.fused.Rd b/man/create.fused.Rd
@@ -62,8 +62,8 @@ D'Orazio, M., Di Zio, M. and Scanu, M. (2006). \emph{Statistical Matching: Theor
 }
 
 \seealso{ 
-\code{\link[StatMatch]{NNN.hotdeck}}
-\code{\link[StatMatch]{RANDwNNN.hotdeck}}
+\code{\link[StatMatch]{NND.hotdeck}}
+\code{\link[StatMatch]{RANDwNND.hotdeck}}
 
 }