data standardization update

DESCRIPTION

@@ -1,9 +1,9 @@
-Package: SCI
+Package: SCI2
 Title: Spatial Cauasal Inference
 Version: 0.0.0.1
 Authors@R: person("Dan", "Runfola", , "[email protected]", role = c("aut", "cre"))
 Description: An alpha release of a package designed to make impact evaluation that includes spatial data easier within R.  See http://www.aiddata.org for more information.
 Depends: R (>= 3.0.2), sp, maptools, reshape, ggplot2, grid, gridExtra, spdep,proj4, FNN, psych
 License: Creative Commons with Attribution
 LazyData: true
-Imports:sp, maptools, reshape, ggplot2, grid, gridExtra, spdep,proj4, FNN, psych
+Imports:sp, maptools, reshape, ggplot2, grid, gridExtra, spdep,proj4, FNN, psych

R/BuildTimeSeries.R

@@ -1,147 +1,235 @@
-BuildTimeSeries <- function(dta,idField,varList_pre,startYear,endYear,colYears=NULL,interpYears=NULL)
-{
-  years <- startYear:endYear
-  #If there is a "colYears" variable, convert to binaries.
-  #Eventually could be extended to more than one column.
-  if(!is.null(colYears))
-  {
-    #For each variable, for each year, create a binary representing the treatment status.
-    for(k in 1:length(years))
-    {
-      for(j in 1:length(colYears))
-      {
-      varN <- paste("TrtMnt_",colYears[j],years[k],sep="")
-      exec <- paste("dta$",varN,"=0",sep="")
-      eval(parse(text=exec))
-
-      dta@data[varN][dta@data[colYears[j]] <= as.numeric(years[k])] <- 1
-      }
-    }
-  }
-  for (j in 1:length(colYears))
-  {
-  trt_id = paste("TrtMnt_",colYears[j],sep="")
-  interpYears <- c(interpYears,trt_id)  
-  }
-  print(interpYears)
-  #If there is an "interpVars" variable, linearly interpolate values based on at least 2 known points in time.
-  if(!is.null(interpYears))
-  {
-    for(AncInt in 1:length(interpYears))
-      {
-        cur_ancVi <- interpYears[AncInt]
-        interpFrame <- dta@data[idField]
-        interpFrame[idField] <- dta@data[idField]
-        cnt = 2
-        for(k in 1:length(years))
-        {
-        #First, build a model describing the relationship between years and any data in the interp field.
-        varI <- paste(cur_ancVi,years[[k]],sep="")
-        #Check if data exists for the year - if not, ignore.  If so, include in the new modeling frame.
-          if(varI %in% colnames(dta@data))
-          {
-            add_data <- paste("interpFrame[cnt] <- dta@data$",varI)
-            eval(parse(text=add_data))
-            colnames(interpFrame)[cnt] <- years[[k]]
-            cnt = cnt + 1
-          } else
-          {
-            #Exception for a single-point interpolation
-            varC <- paste(cur_ancVi,sep="")
-            if(varC %in% colnames(dta@data))
-            {
-              add_data <- paste("interpFrame[cnt] <- dta@data$",varC)
-              eval(parse(text=add_data))
-              cnt = 3
+BuildTimeSeries <- function (dta, idField, varList_pre, startYear, endYear, colYears=NULL, interpYears=NULL) {
+
+    # generate year range 
+    years <- startYear:endYear
+
+
+
+    print("bts1")
+
+    # If there is a "colYears" variable, convert to binaries.
+    # Eventually could be extended to more than one column.
+    if (!is.null(colYears)) {
+        # For each variable, for each year, create a binary representing the treatment status.
+        for (j in 1:length(colYears)) {
+
+            for (k in 1:length(years)) {
+
+                varN = paste("TrtMnt_",colYears[j],"_",years[k], sep="")
+                print(varN)
+
+                dta@data[varN] <- 0
+                dta@data[varN][dta@data[colYears[j]] <= years[k]] <- 1
+                dta@data[varN][is.na(dta@data[colYears[j]])] <- 0
+
             }
-          }
-
+
+            # add the "TrtMnt_" + colYears[j] prefix to interpYears
+            trt_id = paste("TrtMnt_",colYears[j],"_....", sep="")
+            interpYears <- c(interpYears, trt_id)    
         }
-        #Only one time point, so no interpolation is done - value is simply copied to all other columns.
-        if(cnt == 3)
-        {
-          for(k in 1:length(years))
-          {
-            varI <- paste("dta@data$",cur_ancVi,years[[k]]," <- interpFrame[2]",sep="")
-            eval(parse(text=varI))
-          }
-        } else {
-        tDframe <- dta@data[idField]
-        #Here, we model out everything. 
-        #Melt the dataframe for modeling
-        melt_Model_dta <- melt(data.frame(interpFrame),id=idField)
-        melt_Model_dta["variable"] <- as.numeric(gsub("X","",melt_Model_dta$variable))
-
-        #Fit the model for interpolation
-        execstr <- paste("mdl <- lm(value ~ variable + factor(",idField,"),data=melt_Model_dta)",sep="")
-        eval(parse(text=execstr))
-        #Apply the model to interpolate
-        for(u in 1:length(years))
-          {
-          varI <- paste(cur_ancVi,years[[u]],sep="")
-          if(!(varI %in% colnames(dta@data)))
-            {
-            #Variable doesn't exist, so we need to interpolate.
-            tDframe[idField] <- dta@data[idField]
-            tDframe["variable"] <- years[[u]]
-            dta@data[varI] <- predict(mdl,newdata=tDframe)
+    }
+
+    # View(dta)
+    # print(interpYears)
+
+
+
+
+    print("bts2")
+    timer <- proc.time()
+
+    # If there is an "interpVars" variable, linearly interpolate values based on at least 2 known points in time.
+    if (!is.null(interpYears)) {
+
+        for (AncInt in 1:length(interpYears)) {
+
+            print(interpYears[AncInt])
+
+
+            cur_ancVi <- interpYears[AncInt]
+
+            # create interpolation data frame and add id field
+            interpFrame <- dta@data[idField]
+            interpFrame[idField] <- dta@data[idField]
+
+            cnt = 2
+
+
+            print("bts2.0.1")
+
+            # add data to interpolation data frame
+            if (cur_ancVi %in% colnames(dta@data)) {
+                    # Exception for a single-point interpolation
+                    interpFrame[cnt] <- dta@data[,cur_ancVi]
+                    cnt = 3
+
+            } else {
+                for (k in 1:length(years)) {
+                    # First, build a model describing the relationship between years and any data in the interp field.
+
+                    # Check if data exists for the year - if not, ignore.  If so, include in the new modeling frame.
+                    varI <- gsub('....', years[[k]], cur_ancVi, fixed=TRUE)
+                    if (varI %in% colnames(dta@data)) {
+
+                        interpFrame[cnt] <- dta@data[,varI]
+                        colnames(interpFrame)[cnt] <- years[[k]]
+                        cnt = cnt + 1
+
+                    }
+                }
+            }
+
+            print(cnt)
+
+
+            print("bts2.0.2")
+
+            if (cnt == 3) {
+                # only one time point, so no interpolation is done - value is simply copied to all other columns.
+
+                print("bts2.0.2a")
+                for (k in 1:length(years)) {
+                    # add _year to end of non temporal data
+                    dta@data[,paste(cur_ancVi,years[[k]],sep="_")] <- interpFrame[2]
+                }
+
+            } else if (cnt < length(years) + 2) {
+                # run model if data exists for at least two years but not for all years
+                print("bts2.0.2b0")
+
+                # Melt the dataframe for modeling
+                melt_Model_dta <- melt(data.frame(interpFrame), id=idField)
+                melt_Model_dta["variable"] <- as.numeric(gsub("X", "", melt_Model_dta[,"variable"]))
+
+
+                print("bts2.0.2b1")
+
+                # Fit the model for interpolation
+                # this is a slow part
+                execstr <- paste("mdl <- lm(value ~ variable + factor(",idField,"),data=melt_Model_dta)", sep="")
+                eval(parse(text=execstr))
+                # mdl <- lm(value ~ variable + factor(idField), data=melt_Model_dta)
+
+
+                print("bts2.0.2b2")
+
+                # Apply the model to interpolate
+                tDframe <- dta@data[idField]
+
+                for (u in 1:length(years)) {
+
+                    varI <- gsub('....', years[[u]], cur_ancVi, fixed=TRUE)
+                    if (!(varI %in% colnames(dta@data))) {
+                        # Variable doesn't exist, so we need to interpolate.
+                        tDframe[idField] <- dta@data[idField]
+                        tDframe["variable"] <- years[[u]]
+                        dta@data[varI] <- predict(mdl, newdata=tDframe)
 
+                    }
+                }
             }
-          }     
+
         }
-
-      }
-
-    #Append interpolated fields to our melting lists
-    for(v in 1:length(interpYears))
-      {
-      varList_pre[[length(varList_pre)+1]] <- interpYears[v]
-      }
+
+        print("bts2.1")        
+        # Append interpolated fields to our melting lists
+        varList_pre <- c(varList_pre, interpYears)
 
-  }
-
-
-  #Run the melts
-
-  meltList <- list()
-  for (i in 1:length(varList_pre))
-  {
-    #grep_str = paste(idField,"|",varList_pre[i],"[0-9][0-9][0-9][0-9]",sep="")
-    #Limit to only relevant years
-    grepStrYrs = idField
-    for(j in 1:length(years))
-    {
-      tempGrep <- grepStrYrs
-      grepStrYrs <- paste(tempGrep,"|",varList_pre[[i]],years[[j]],sep="")
     }
-    tDF <- dta@data[grepl(grepStrYrs,names(dta@data))]
-    meltList[[i]] <- melt(tDF,id=idField)
-
-    #Keep only years in the year column, rename columns
-    colnames(meltList[[i]])[2] <- "Year"
-    colnames(meltList[[i]])[3] <- varList_pre[[i]]
-
-    #Clean up year column
-    gsub_command <- paste("^",varList_pre[[i]],sep="")
-    meltList[[i]][2] <- gsub(gsub_command, "", as.matrix(meltList[[i]][2]))
-
-
-    #Remove ID and year if this is at least the second variable to avoid duplications.
-    if(i > 1)
-    {
-      meltList[[i]] <- meltList[[i]][3]
+
+    print(varList_pre)
+
+    timer <- proc.time() - timer
+    print(paste("section completed in", timer[3], "seconds."))
+
+
+
+
+    print("bts3")
+    timer <- proc.time()
+
+    # Run the melts
+    meltList <- list()
+    for (i in 1:length(varList_pre)) {
+
+        print("bts3.0")
+        print(varList_pre[[i]])
+
+        # Limit to only relevant years
+        grepStrYrs = idField
+
+        for (j in 1:length(years)) {
+            tempGrep <- grepStrYrs
+
+            if (regexpr("....", varList_pre[[i]], fixed=TRUE)[1] == -1) {
+                grepStrYrs <- paste(tempGrep,"|",paste(varList_pre[[i]],years[[j]], sep="_"), sep="")
+            } else {
+                grepStrYrs <- paste(tempGrep,"|",gsub('....', years[[j]], varList_pre[[i]], fixed=TRUE), sep="")
+            }
+        }
+
+        print(grepStrYrs)
+
+        print("bts3.1")
+        # print(names(dta@data))
+
+        tDF <- dta@data[grepl(grepStrYrs, names(dta@data))]
+        meltList[[i]] <- melt(tDF, id=idField)
+
+        print("bts3.2")
+        # print(colnames(meltList[[i]]))
+        # Keep only years in the year column, rename columns
+        colnames(meltList[[i]])[2] <- "Year"
+
+        print("bts3.3")
+
+        colnames(meltList[[i]])[3] <- varList_pre[[i]]
+
+
+        print("bts3.4")
+
+        if (i == 1) {
+            # set field to use for regex when formatting year field later
+            year_regex_field <- varList_pre[[i]]
+
+        } else {
+            # remove id and year after first pass to avoid duplications
+            meltList[[i]] <- meltList[[i]][3]
+
+        }
+
     }
 
-  }
+    timer <- proc.time() - timer
+    print(paste("section completed in", timer[3], "seconds."))
 
-  #Finish up with a cherry on top
-  meltListRet <- data.frame(meltList)
-
-  return(meltListRet)
+
+
+
+    print("bts4")
+
+    # convert meltList to data frame
+    meltListRet <- data.frame(meltList)
+
+    # format year
+    regex_test <- regexpr("....", year_regex_field, fixed=TRUE)[1]
+    if (regex_test > -1) {
+        meltListRet['Year'] <- lapply(meltListRet['Year'], function (z) {
+            return(as.integer(substr(z, regex_test, regex_test+nchar("....")-1)))
+        })
+
+    } else {
+        meltListRet['Year'] <- lapply(meltListRet['Year'], function (z) {
+            return(as.integer(substr(z, nchar(z)-nchar("....")+1, nchar(z))))
+        })
+    }
+
+    return(meltListRet)
 }
 
 
 # dm1 <- melt(d[,c("Type","I.alt","idx06","idx07","idx08")], id=c("Type","I.alt"))
 # dm2 <- melt(d[,c("Type","I.alt","farve1","farve2")], id=c("Type","I.alt"))
 # colnames(dm2) <- c("Type", "I.alt", "variable2", "value2")
-# dm <- merge(dm1, dm2)
+# dm <- merge(dm1, dm2)