diff --git a/R/construct_repair.R b/R/construct_repair.R new file mode 100644 index 00000000..9acee103 --- /dev/null +++ b/R/construct_repair.R @@ -0,0 +1,117 @@ +# FIXME: append() scrapes the class and attributes +# we might use an append replacement depending on the class +# or we just reconstruct all attrs after append(), but this might not be very minimal + +construct_repair <- function(target, ref) { + ref_code <- deparse_call(substitute(ref)) + calls <- rec(target, ref, template = NULL) + code <- pipe(ref_code, calls, pipe = "magrittr", one_liner = FALSE) + code[[length(code)]] <- sub(" %>%$", "", code[[length(code)]]) + styler::style_text(code) +} + +#TODO + +rec <- function(target, ref, ind = NULL, ...) { + + # remove or add at top level + l_target <- length(target) + l_ref <- length(ref) + attrs_ref <- attributes(ref) + attrs_target <- attributes(target) + attrs_ref$names <- NULL + attrs_target$names <- NULL + n_common <- min(l_target, l_ref) + calls <- character() + + # FIXME: we might make this a unlist(sapply()) once we return rather than print + for (i in seq_len(n_common)) { + if (!identical(target[[i]], ref[[i]])) { + if (!is.list(target[[i]]) || !is.list(ref[[i]])) { + # FIXME: deal with the case where only attributes need to be repaired + ind_code <- construct_raw(c(ind, i), ...) + target_code <- construct_raw(target[[i]], ...) + target_code <- paste0("~", target_code) + call <- construct_apply(list(ind_code, target_code), "purrr::modify_in", language = TRUE, ...) + calls <- c(calls, pipe(call, NULL, pipe = "magrittr", one_liner = FALSE)) + } else { + call <- rec(target[[i]], ref[[i]] , c(ind, i), ...) + calls <- c(call, calls) + } + } + } + + if (l_ref > l_target) { + # remove + for (i in (l_target + 1):l_ref) { + ind_code <- construct_raw(c(ind, i), ...) + target_code <- "~NULL" + calls <- construct_apply(list(ind_code, target_code), "purrr::modify_in", language = TRUE, ...) + calls <- c(calls, pipe(call, NULL, pipe = "magrittr", one_liner = FALSE)) + } + } + + if (l_target > l_ref) { + for (i in (l_ref + 1):l_target) { + if (is.null(ind)) { + call <- construct_apply(list(target[i]), "append", ...) + } else { + # ind_code <- construct_raw(c(ind, i), ...) + # target_code <- construct_raw(target[[i]], ...) + call <- construct_apply(list(c(ind, i), "append", target[i]), "purrr::modify_in", ...) + } + calls <- c(calls, pipe(call, NULL, pipe = "magrittr", one_liner = FALSE)) + } + if(!identical(names(ref), names(target)[seq_along(ref)])) { + if (is.null(ind)) { + call <- construct_apply(list(names(target)[seq_along(ref)]), "setNames", ...) + } else { + call <- construct_apply(list(ind, "setNames", names(target)[seq_along(ref)]), "purrr::modify_in", ...) + } + calls <- c(calls, pipe(call, NULL, pipe = "magrittr", one_liner = FALSE)) + } + } + + if (!identical(attrs_ref, attrs_target)) { + # we loop through the args and ignore as long as they are the same and named identically + for (i in seq_along(attrs_target)) { + if (identical(names(attrs_target)[[1]], names(attrs_ref)[[1]]) && + identical(attrs_target[[i]], attrs_ref[[i]])) { + attrs_target[[i]] <- NULL + attrs_ref[[i]] <- NULL + } else { + break + } + } + # attributes to remove from ref + if (length(attrs_ref)) { + attrs_ref[] <- list(NULL) + } + attrs <- c(attrs_ref, attrs_target) + + if (is.null(ind)) { + call <- construct_apply(attrs, "structure", ...) + } else { + call <- construct_apply(c(list(ind), "structure", attrs), "purrr::modify_in", ...) + } + calls <- c(calls, pipe(call, NULL, pipe = "magrittr", one_liner = FALSE)) + } + + calls +} + +# foo <- list(1) +# attributes(foo) <- list(a1=1,a2=2) +# bar <- list(1) +# attributes(bar) <- list(a1=1,a3=2) +# x <- list(foo) +# y <- list(bar) +# construct_repair(x, y) +# x <- list(a=1, b= list(u =2, v = 3)) +# y <- list(a=1, b= data.frame(u =2, v = 3)) +# y <- list(a=1, b= list(u =2, v = factor("c", levels = letters[1:3]))) +# y <- list(a=1) +# y <- list(a=1, b = 3, c = ) +# +# +# construct_repair(x, y)