I have the following data frame:
set.seed(1)
SOURCE <- as.data.frame(matrix(c((1:10),
sample(c("20-24","25-28"), 10, replace = TRUE),
sample(c("10000", "20000"), 10, replace = TRUE),
sample(c(1, NA), 10, replace = TRUE),
sample(c(2, NA), 10, replace = TRUE),
sample(c(3, NA), 10, replace = TRUE)), nrow = 10), stringsAsFactors = FALSE)
names(SOURCE) <- c("id", "age", "income", "IS_1", "IS_2", "IS_3")
SOURCE$SUM_1 <- sample(c(1000, 10000), 10, replace = TRUE) * as.numeric(SOURCE$IS_1)
SOURCE$SUM_2 <- sample(c(1000, 10000), 10, replace = TRUE) * as.numeric(SOURCE$IS_2)
SOURCE$SUM_3 <- sample(c(1000, 10000), 10, replace = TRUE) * as.numeric(SOURCE$IS_3)
For each line I want to find additional IS group, by doing the following:
SOURCE$BUCKET <- do.call(paste, c(SOURCE[, c(4,5,6)]))
for (i in 1:nrow(SOURCE)) {
steady <- as.vector(read.table(text = SOURCE$BUCKET[i], sep = " ", colClasses = "numeric"))
ready <- steady[!is.na(steady)]
SOURCE$IS_BREADTH[i] <- length(ready)
SOURCE$PATTERN[i] <- paste0("(?=.*", ready, ")", collapse = "")
}
require("data.table")
DIMPORT <- data.table(SOURCE)
Also, I don't want my algorithm to return me the same IS group, the person is active in. So I use the following:
na.replace <- function (x) {
ifelse(is.na(x) == TRUE, x <- 1, x <- NA)
return(x)
}
And here comes the iterative part:
j <- data.frame()
d <- data.frame()
for (i in 1:nrow(DIMPORT)) {
print(i)
Xid <- DIMPORT$id[i]
Xage <- DIMPORT$age[i]
Xpattern <- DIMPORT$PATTERN[i]
Xincome <- DIMPORT$income[i]
Xbreadth <- DIMPORT$IS_BREADTH[i]
if (DIMPORT$IS_BREADTH[i] == 0){
Xcategory <- "UNKNOWN"
Xsum <- "UNKNOWN"
j <- as.data.frame(matrix(c(Xid, Xage, Xpattern, Xincome, Xcategory, Xsum), nrow = 1))
d <- rbind(d, j)
} else {
DSEGMENT <- DIMPORT[age == Xage & IS_BREADTH == Xbreadth + 1 & income == Xincome & grepl(Xpattern, DIMPORT$BUCKET, perl = TRUE)]
if (nrow(DSEGMENT) == 0) {
Xcategory <- "UNDETECTABLE"
Xsum <- "UNDETECTABLE"
j <- as.data.frame(matrix(c(Xid, Xage, Xpattern, Xincome, Xcategory, Xsum), nrow = 1))
d <- rbind(d, j)
} else {
IS_vector <- c(na.replace(DIMPORT$IS_1[i]), na.replace(DIMPORT$IS_2[i]), na.replace(DIMPORT$IS_3[i]))
DZ <- DSEGMENT[, list("1" = sum(!is.na(IS_1)) / length(id), "2" = sum(!is.na(IS_2)) / length(id), "3" = sum(!is.na(IS_3)) / length(id))] * IS_vector
category <- paste0(names(which.max(DZ)))
DB <- DSEGMENT[, grepl(paste0("(?=.*_", category, "$)", collapse = ""), names(DSEGMENT), perl = TRUE), with = FALSE]
names(DB) <- c("IS", "SUM")
DB <- DB[complete.cases(DB)]
Xsum <- as.character(DB[, list(SPEND_PER_ID = sum(SUM) / nrow(DB))])
Xcategory <- category
j <- as.data.frame(matrix(c(Xid, Xage, Xpattern, Xincome, Xcategory, Xsum), nrow = 1))
d <- rbind(d, j)
}
}
}
The result is fine, though the speed is about 2 lines per second in non-mockup data (127 columns). Is there any way to improve the speed?
SOURCE
andDIMPORT
meant to be the same object? If yes, shouldSOURCE
contain anIS_BREADTH
column? \$\endgroup\$IS_???
andSUM_???
columns? How many exactly? Are theIS_???
meant to be booleans? I see you for example fill IS_2 with two types of values: 2 or NA. Does a value of2
means "yes" and a value ofNA
mean "no"? Also, what is the meaning of theSUM_???
columns? \$\endgroup\$