Merge pull request #1891 from dannyparsons/factor_df

added create factor data frame method

instat/static/InstatObject/R/Backend_Components/link.R

@@ -29,11 +29,9 @@ link$set("public", "equals", function(compare_link) {
          && self$to_data_frame == compare_link$to_data_frame
          && self$type == compare_link$type) {
     if(self$type == keyed_link_label) {
-      #print(self$calculation$parameters)
-      #print(compare_link$calculation$parameters)
       if(setequal(self$calculation$parameters, compare_link$calculation$parameters) && setequal(names(self$calculation$parameters), names(compare_link$calculation$parameters))) {
-        for(name in names(compare_link$calculation$parameters)) {
-          if(compare_link$calculation$parameters[[name]] != self$calculation$parameters[[name]]) return(FALSE)
+        for(factor_col in compare_link$calculation$parameters) {
+          if(!factor_col %in% self$calculation$parameters) return(FALSE)
         }
       return(TRUE)
       }
@@ -71,4 +69,19 @@ instat_object$set("public", "add_link", function(link_object) {
 instat_object$set("public", "link_exists", function(new_link) {
   return(any(sapply(private$.links, function(link) link$equals(new_link))))
 }
+)
+
+instat_object$set("public", "link_exists_from", function(from_data_frame, factors) {
+  link_calc <- calculation$new(type = "summary", parameters = factors)
+  link_obj <- link$new(from_data_frame = from_data_frame, type = keyed_link_label, calculation = link_calc)
+  exists = FALSE
+  for(data_obj in self$get_data_objects()) {
+    link_obj$to_data_frame <- data_obj$get_metadata(data_name_label)
+    if(self$link_exists(link_obj)) {
+      exists = TRUE
+      break
+    }
+  }
+  return(exists)
+}
 )

instat/static/InstatObject/R/Backend_Components/summary_functions.R

@@ -33,7 +33,6 @@ data_object$set("public", "merge_data", function(new_data, by = NULL, type = "le
 instat_object$set("public", "append_summaries_to_data_object", function(out, data_name, columns_to_summarise, summaries, factors = c(), summary_name, calc, calc_name = "") {
   if(!is.character(data_name)) stop("data_name must be of type character")
   factors_list <- factors
-  names(factors_list) <- factors
   link_calc <- calculation$new(type = "summary", parameters = factors_list)
   link_obj <- link$new(from_data_frame = data_name, type = keyed_link_label, calculation = link_calc)
   exists = FALSE

instat/static/InstatObject/R/instat_object_R6.R

@@ -952,4 +952,45 @@ instat_object$set("public","make_date_yeardoy", function(data_name, year, doy, y
 instat_object$set("public","set_contrasts_of_factor", function(data_name, factor, new_contrasts) {
   self$get_data_objects(data_name)$set_contrasts_of_factor(factor = factor, new_contrasts = new_contrasts)
 }
+)
+
+instat_object$set("public","create_factor_data_frame", function(data_name, factor, factor_data_frame_name, include_contrasts = TRUE, replace = FALSE) {
+  curr_data_obj <- self$get_data_objects(data_name)
+  if(!factor %in% names(curr_data_obj$get_data_frame())) stop(factor, " not found in the data")
+  if(!is.factor(curr_data_obj$get_columns_from_data(factor))) stop(factor, " is not a factor column.")
+  create <- TRUE
+  if(self$link_exists_from(data_name, factor)) {
+    message("Factor data frame already exists.")
+    if(replace) {
+      message("Current factor data frame will be replaced.")
+      #TODO replacing not implemented yet
+      # This line should be removed when implemented
+      create <- FALSE
+    }
+    else create <- FALSE
+  }
+  if(create) {
+    data_frame_list <- list()
+    if(missing(factor_data_frame_name)) factor_data_frame_name <- paste0(data_name, "_", factor)
+    factor_data_frame_name <- make.names(factor_data_frame_name)
+    factor_data_frame_name <- next_default_item(factor_data_frame_name, self$get_data_names(), include_index = FALSE)
+
+    factor_column <- curr_data_obj$get_columns_from_data(factor)
+    factor_data_frame <- data.frame(levels(factor_column))
+    names(factor_data_frame) <- factor
+    if(include_contrasts) {
+      factor_data_frame <- cbind(factor_data_frame, contrasts(factor_column))
+    }
+    row.names(factor_data_frame) <- 1:nrow(factor_data_frame)
+    names(factor_data_frame)[2:ncol(factor_data_frame)] <- paste0("C", 1:(ncol(factor_data_frame)-1))
+    data_frame_list[[factor_data_frame_name]] <- factor_data_frame
+    self$import_data(data_frame_list)
+    factor_data_obj <- self$get_data_objects(factor_data_frame_name)
+    factor_data_obj$add_key(factor)
+    link_calc <- calculation$new(type = "summary", parameters = factor)
+    link_obj <- link$new(from_data_frame = data_name, type = keyed_link_label, calculation = link_calc)
+    link_obj$to_data_frame <- factor_data_frame_name
+    self$add_link(link_obj)
+  }
+}
 )