redid thicken_helpers in c++

DESCRIPTION

@@ -10,7 +10,9 @@ Encoding: UTF-8
 LazyData: true
 Imports:
     dplyr,
-    magrittr
+    magrittr,
+    Rcpp
 Suggests:
     testthat
 RoxygenNote: 5.0.1
+LinkingTo: Rcpp

NAMESPACE

@@ -1,3 +1,5 @@
 # Generated by roxygen2: do not edit by hand
 
 export(thicken)
+importFrom(Rcpp,sourceCpp)
+useDynLib(padr)

R/RcppExports.R

@@ -0,0 +1,11 @@
+# This file was generated by Rcpp::compileAttributes
+# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
+
+round_down_core <- function(a, b) {
+    .Call('padr_round_down_core', PACKAGE = 'padr', a, b)
+}
+
+round_up_core <- function(a, b) {
+    .Call('padr_round_up_core', PACKAGE = 'padr', a, b)
+}
+

R/fill_functions.R

@@ -0,0 +1,30 @@
+
+x <- seq(ymd('20150101'), ymd('20160101'), by = 'day') %>%
+  sample(200) %>% sort %>% data_frame(x = .)
+x$y <- runif(200, 1, 20) %>% round
+x$z <- sample(LETTERS[1:5], 200, TRUE)
+x$w <- rnorm(200, 2, 2) %>% round(2)
+x <- pad(x)
+
+fill_na_by_mean <- function(x, ...){
+  arguments <- as.list(match.call())
+  x <- as.data.frame(x)
+  if(length(arguments) == 2) {
+    cols_to_fill_ind <- sapply(x, class) %in% c('integer', 'numeric') %>% which
+    cols_to_fill_name <- colnames(x)[cols_to_fill_ind]
+  } else {
+    cols_to_fill_names <- arguments[3:length(arguments)] %>% as.character
+    cols_to_fill_ind   <- colnames(x) %in% cols_to_fill_names %>% which
+    if(length(cols_to_fill_ind) != cols_to_fill_names) {
+      stop('One or more supplied variables to fill is not a column name.')
+    }
+  }
+  means <- x[cols_to_fill] %>% colMeans(na.rm = TRUE)
+  fill_na <- function(x, m) ifelse(x %>% is.na, m, x)
+
+  filled <- mapply(fill_na, x[cols_to_fill_ind], means)
+
+  # TODO place filled back in x and return
+}
+
+

R/pad.R

@@ -48,20 +48,24 @@ pad <- function(x,
 
   span <- span_pad(dt_var, start_val, end_val, interval)
 
-
   if(!is.data.frame(x)){
     return(span)
   } else {
     join_frame <- data.frame(span = span)
     colnames(original_data_frame)[colnames(original_data_frame) ==
                                     dt_var_name] <- 'span'
-    return_frame <- dplyr::right_join(original_data_frame, join_frame)
+    return_frame <- suppressMessages(
+      dplyr::right_join(original_data_frame, join_frame))
     colnames(return_frame)[colnames(return_frame) == 'span'] <- dt_var_name
+    class(return_frame) <-  class(original_data_frame)
     return(return_frame)
   }
 }
 
 
+# this is a helper function for pad, spanning for pad is much simpler
+# than for thicken. Adjusting the span_ functions for pad would make them
+# too fuzzy.
 span_pad <- function(x,
                      start_val = NULL,
                      end_val   = NULL,

R/pad_df_helpers.R → R/pad_helpers.R

@@ -70,3 +70,11 @@ get_date_variables <- function(df){
     names
   return(date_classes)
 }
+
+
+# These two Roxygen tags are required to use Cpp code (they could be anywhere
+# in the package)
+
+#' @useDynLib padr
+#' @importFrom Rcpp sourceCpp
+NULL

R/smear.R

@@ -37,6 +37,10 @@ you might be looking fo thicken rather than for thicken.')
 you might be looking for pad rather than for thicken.')
   }
 
+  if(!all(dt_var[1:(length(dt_var)-1)] < dt_var[2:length(dt_var)])) {
+   warning('Datetime variable was unsorted, result will be unsorted as well.')
+  }
+
   # The smearing is done at POSIXct level, if applicable later converted back to Date
   start_val   <- min(dt_var)
   end_val     <- max(dt_var) %>% as.POSIXct
@@ -66,7 +70,8 @@ you might be looking for pad rather than for thicken.')
   } else {
     colnames(original_data_frame)[colnames(original_data_frame) ==
                                     dt_var_name] <- 'original'
-    return_frame <- dplyr::inner_join(original_data_frame, join_frame)
+    return_frame <- suppressMessages(
+      dplyr::inner_join(original_data_frame, join_frame))
     colnames(return_frame)[colnames(return_frame) == 'original'] <- dt_var_name
     return(return_frame)
   }

R/span_functions.R

@@ -177,9 +177,9 @@ span_day <- function(x,
                      start_val= NULL,
                      end_val  = NULL){
   # Initialize
-#  if('Date' %in% class(x)){
-#    stop('To use span_day x should be of class POSIXt', call. = FALSE)
-#  }
+  if('Date' %in% class(x)){
+    stop('To use span_day x should be of class POSIXt', call. = FALSE)
+  }
 
   start_at_null <- min(x)
   lubridate::hour(start_at_null) <-
@@ -249,6 +249,10 @@ span_hour <- function(x,
                       start_val= NULL,
                       end_val  = NULL){
   # Initialize
+  if('Date' %in% class(x)){
+    stop('To use span_day x should be of class POSIXt', call. = FALSE)
+  }
+
   start_at_null <- min(x)
   lubridate::minute(start_at_null) <- lubridate::second(start_at_null) <- 0
 
@@ -294,13 +298,6 @@ span_hour <- function(x,
 
   }
 
-  if(class(start_seq) == "Date") {
-    start_seq <- as.POSIXct(start_seq)
-    lubridate::hour(start_seq) <- 0
-    end_seq <- as.POSIXct(end_seq)
-    lubridate::hour(end_seq) <- 0
-  }
-
   span <- seq(start_seq, end_seq, 'hour')
   if(class(x)[1] == 'POSIXlt') span <- span %>% as.POSIXlt
   return(span)
@@ -317,6 +314,10 @@ span_minute <- function(x,
 
 
   # Initialize
+  if('Date' %in% class(x)){
+    stop('To use span_day x should be of class POSIXt', call. = FALSE)
+  }
+
   start_at_null <- min(x)
   lubridate::second(start_at_null) <- 0
 
@@ -364,14 +365,6 @@ span_minute <- function(x,
 
   }
 
-  if(class(start_seq) == "Date") {
-    start_seq <- as.POSIXct(start_seq)
-    lubridate::hour(start_seq) <- 0
-    end_seq <- as.POSIXct(end_seq)
-    lubridate::hour(end_seq) <- 0
-  }
-
-
   span <- seq(start_seq, end_seq, 'min')
   if(class(x)[1] == 'POSIXlt') span <- span %>% as.POSIXlt
   return(span)