# ------------------------------------------------------------------ # # HELPER FUNCTIONS # # ------------------------------------------------------------------ # ## --- these can be general utils, I believe ---- # isTopPerc <- function(vec, perc, na.rm=TRUE, top=(perc>.5)) { if (length(perc) != 1) stop ("perc should be o single number. (ie, `length(perc) == 1` should be TRUE.") if (top) vec > quantile(vec, prob=perc, na.rm=na.rm) else vec < quantile(vec, prob=perc, na.rm=na.rm) } mutualTopRows <- function(DT, cols, perc=.999, by=NULL, returnDT=FALSE, top=(perc>.5)) { # sumFunc : to allow for identity if (is.null(by)) if (!returnDT) return(which(rowSums(DT[, lapply(.SD, isTopPerc, perc=perc, top=top), .SDcols=cols]) > 0)) else return(DT[, lapply(.SD, isTopPerc, perc=perc, top=top), .SDcols=cols][, SUMS := rowSums(.SD, na.rm=TRUE)] ) else ## TODO: Look into `rowsum` instead of `rowSums` return( DT[, c(list(ROWNUMBER=seq(.N)), .SD) ][, c(list(ROWNUMBER=ROWNUMBER) , lapply(.SD[,-1,with=FALSE], isTopPerc, perc=.999)) , .SDcols=c("ROWNUMBER",cols), by=by ][, list(isTop=rowSums(.SD)>0) , by=c("ROWNUMBER", by) ][c(isTop), ROWNUMBER] ) } ## --- these can be general utils, I believe ---- # noDot <- function(x) gsub("\\.", "_", gsub("^\\.", "", x) ) ## Wrapper function for aggregating aggBy <- function(DT, byCols, DateIn=FALSE, DateOut=FALSE, verbose=TRUE , cols.agging, cols.keeping=".all", cols.dropping=NULL) { # if DateIn, will add "Date" to the front of `byCols` if not already present # if DateOut, will remove "Date" from `byCols` if present. # If both are FALSE will leave byCols as they are. ## Default the value of cols.agging to cols.mets, if the latter exists. if (missing(cols.agging)) { if (exists("cols.mets", envir=parent.frame())) cols.agging <- get("cols.mets", envir=parent.frame()) else stop("You forgot to specify `cols.agging` (which columns to aggregate) and there is no `cols.mets` in the parent environment.") } if (DateOut && DateIn) stop("Cannot have *both* DateIn & DateOut be TRUE. Pick one.") if (DateIn && !("Date" %in% byCols)) byCols <- c("Date", byCols) if (DateOut) byCols <- setdiff(byCols, "Date") ## Decide which columns to keep if (isTRUE(cols.keeping[[1]]==".all")) { cols.keeping <- setdiff(names(DT), c(cols.agging, byCols)) } cols.keeping <- setdiff(cols.keeping, cols.dropping) cols.keeping <- intersect(cols.keeping, names(DT)) if (verbose) { # the sole purpose of these next two lines is to preserve the order of cols.dropping in the verbose output unused <- setdiff(names(DT), c(cols.agging, byCols, cols.keeping)) unused <- c(intersect(cols.dropping, names(DT)), setdiff(unused, intersect(unused, cols.dropping))) cat("\n\n") cat("Cols using for aggregation are: ", paste("", byCols, sep="\n\t"), "\n\n") cat("Additionally, also including (or aggregating by): \n", if(length(cols.keeping)) paste_l(cols.keeping, ", ", usefw=TRUE) else "< none >", "\n\n", sep="\t") cat("Cols being aggregated are: \n", paste_l(cols.agging, ", ", usefw=TRUE), "\n\n", sep="\t") cat("Cols being **_dropped_** are: \n", paste_l(unused, ", ", usefw=TRUE), sep="\t") cat("\n\n") } # Aggregate, usng `sum`, and return a copy copy(DT[, lapply(.SD, sum), .SDcols=cols.agging, keyby=c(byCols, cols.keeping)]) } # ------------------------------------------------------------------ # ## Aggregate each Demog col, other than Date computeTotals <- function(DT, col.Total, byCols=NULL, col.mets, reorder=TRUE) { tt <- setNames(as.list(rep("TOTAL", length(col.Total))), col.Total) ## RETURN if (reorder) setcolorderpt( DT[, c(lapply(.SD, sum), tt), .SDcols=col.mets, by=byCols] , intersect(names(DT), c(byCols, col.Total, col.mets)) ) else DT[, c(lapply(.SD, sum), tt), .SDcols=col.mets, by=byCols] } # ------------------------------------------------------------------ # cleanInf <- function(x) { x[is.infinite(x)] <- NaN x } removeBlankRows <- function(DF) { blankRows <- rowSums(DF=="") == ncol(DF) DF[!blankRows, ] } addCutCol <- function(DT, cut.col = "CPC", logOrLinear=c("log", "linear"), breaks, from=ifelse(logOrLinear=="log", -2, 0), to=5, by=.15, assignTo, asDollars=FALSE, dollarsDec=2, noWarnOnChar=FALSE, useRoundLeft=FALSE) { # cut.col.lab=paste0(cut.col, ".cut.lab"), cropTop=FALSE, require(Hmisc) RLfunc <- if (useRoundLeft) roundLeft else identity if (length(cut.col) != 1) stop("`cut.col` must have length exactly one.") logOrLinear <- match.arg(logOrLinear) if (missing(assignTo)) { assignTo <- switch(cut.col, "CPC" = "Cost.Per.Click", "CPA" = "Cost.Per.Action", "CPM" = "Cost.Per.kViews", "Spend" = "Total.Campaign.Spend", paste0(cut.col, ".cut") ) } if (missing(breaks)) { breaks <- seq(from=from, to=to, by=by) if(logOrLinear=="log") breaks <- 10^breaks } DT[, c(assignTo) := cut2(get(cut.col), cuts=breaks, levels.mean=TRUE, oneval=FALSE)] ## TODO: Not sure why there is a level " NA". Google this and make sure not an issue. # levels(DT[[assignTo]]) [stringr::str_trim(levels(DT[[assignTo]])) == "NA"] <- NA if (asDollars) { DT[, c(assignTo) := droplevels(setattr(get(assignTo), "levels", asCurr( RLfunc(levels(get(assignTo))), decim=dollarsDec, noWarnOnChar=noWarnOnChar ) ))] } return(invisible(DT)) } cleanCampName <- function(x, substrLen=20, toFactor=is.factor(x)) { force(toFactor) ## First Remove Dates and brackets. ## If after the second part, nothing remains, we will substr here x <- gsub(regOr(c(date.mmddyyyy.regex, "\\[", "\\]"), whitespace=TRUE), "", x, ignore.case=TRUE) patsToRem <- c(NULL , "\\bCPC\\b" , "Sponsored" , "Promoting" , "Promotion" , "Promoted Post" , "\\-?Page Likes\\-?" , date.mmddyyyy.regex , "\\(.*Label ID\\: [0-9]+\\)" , "\\(?Compilation[s]* ID\\: [0-9]+\\)?" , "\\-?Post Engagement" , "\\[", "\\]", "\\(", "\\)" , "(Clicks)?\\-?US\\-\\d\\d\\-\\d\\d\\-?" , "\\- ?Promo" , "\\.(\\.)+" , "\\-?Weekend\\-?" ) ret <- gsub(regOr(patsToRem, whitespace=TRUE), "", x, ignore.case=TRUE) ## replace periods with underscore (for JS) ret <- gsub("[[:punct:]]", "_", ret) # Check for any values that have been made into blanks. Restore back to x blanks <- ret=="" if (any(blanks)) { ret[blanks] <- x[blanks] } # Take a substring, try to cut it cleanly at a whitespace ret <- substr(ret, 1, substrLen*1.3) endAt <- findLastSpace(ret) recrop <- endAt > substrLen*0.8 # recrop ret[recrop] <- substr(ret[recrop], 1, endAt[recrop]) # a bit of last cleanup ret <- gsub(" ID: ?| the ?", "", ret) ret <- stringr::str_trim(ret) # remove double spaces ret <- gsub(" ( )+", " ", ret) if (toFactor) ret <- as.factor(ret) return(ret) } # ================================ # # Numerator & Denominator should be string columns calc.Ratio_ <- function(DT, assignTo, num, denom, per=1L, by=NULL) { invisible( DT[, c(assignTo) := cleanInf(get(num) * per / get(denom)), by=by] ) } # ------------------ # calc.CPM_ <- function(DT, assignTo="CPM", Impressions.col="Impressions", Cost.col="Spend", per=1000L, by=NULL) { calc.Ratio_(DT=DT, assignTo=assignTo, num=Cost.col, denom=Impressions.col, per=per, by=by) } calc.CPC_ <- function(DT, assignTo="CPC", Cost.col="Spend", Clicks.col="Clicks", per=1L, by=NULL) { calc.Ratio_(DT=DT, assignTo=assignTo, num=Cost.col, denom=Clicks.col, per=per, by=by) } # as a percentage calc.CTR_ <- function(DT, assignTo="CTR", Impressions.col="Impressions", Clicks.col="Clicks", per=100L, by=NULL) { calc.Ratio_(DT=DT, assignTo=assignTo, num=Clicks.col, denom=Impressions.col, per=per, by=by) } # ------------------ # # Same functions for Unique calc.uCPM_ <- function(DT, assignTo="uCPM", Impressions.col="Reach", Cost.col="Spend", per=1000L, by=NULL) { calc.CPM_(DT=DT, assignTo=assignTo, Impressions.col=Impressions.col, Cost.col=Cost.col, per=per, by=by) } calc.uCPC_ <- function(DT, assignTo="uCPC", Cost.col="Spend", Clicks.col="uClicks", per=1L, by=NULL) { calc.CPC_(DT=DT, assignTo=assignTo, Cost.col=Cost.col, Clicks.col=Clicks.col, per=per, by=by) } calc.uCTR_ <- function(DT, assignTo="uCTR", Impressions.col="Reach", Clicks.col="uClicks", per=100L, by=NULL) { calc.CTR_(DT=DT, assignTo=assignTo, Clicks.col=Clicks.col, Impressions.col=Impressions.col, per=per, by=by) } # ------------------ # calc.Freq <- function(DT, assignTo="Freq.Of.Impressions.Per.User", Total.Count.col="Impressions", Unique.Count.col="Reach", per=1L, by=NULL) { calc.Ratio_(DT=DT, assignTo=assignTo, num=Total.Count.col, denom=Unique.Count.col, per=per, by=by) # Replace division-by-Zero with NaN # invisible(DT[is.infinite(get(assignTo)), c(assignTo) := NaN]) } addCalcCols_ <-function(DT, addUniques=TRUE, addSplits=TRUE, addGVisID=FALSE, calcBy=NULL) { ## ------------------------------------ ## ## Add a unique index for googleVis ## ## ------------------------------------ ## if (addGVisID) { byCols <- setdiff(key(DT), "Date") DT[, ".GVisID" := (.GRP), by=byCols] setcolorderpt(DT, ".GVisID") } ## ------------------------------------ ## ## Calculate key metric summaries ## ## ------------------------------------ ## calc.Freq(DT, by=calcBy) calc.Freq(DT, assignTo="Freq.Of.Actions.Per.User", Total.Count.col="Actions", Unique.Count.col="PeopleActioning", by=calcBy) calc.CTR_(DT, by=calcBy) calc.CPC_(DT, Cost="Spend", by=calcBy) calc.CPM_(DT, Cost="Spend", by=calcBy) calc.CTR_(DT, Click="Actions", assignTo="ATR", by=calcBy) calc.CPC_(DT, Cost="Spend", Click="Actions", assignTo="CPA", by=calcBy) if ("Shares.post" %in% names(DT)) { calc.Ratio_(DT, assignTo="SharesPerM", num="Shares.post", denom="Impressions", per=1000L, by=calcBy) calc.Ratio_(DT, assignTo="uSharesPerM", num="Shares.post", denom="Reach", per=1000L, by=calcBy) if ("Soc.Impressions" %in% names(DT)) calc.Ratio_(DT, assignTo="Soc.SharesPerM", num="Shares.post", denom="Soc.Impressions", per=1000L, by=calcBy) if ("Soc.Reach" %in% names(DT)) calc.Ratio_(DT, assignTo="Soc.uSharesPerM", num="Shares.post", denom="Soc.Reach", per=1000L, by=calcBy) } if (addUniques) { ## ------------------------------------ ## ## Calculate metric summaries of unique hits ## ## ------------------------------------ ## calc.uCTR_(DT, by=calcBy) calc.uCPC_(DT, Cost="Spend", by=calcBy) calc.uCPM_(DT, Cost="Spend", by=calcBy) calc.uCTR_(DT, Click="PeopleActioning", assignTo="uATR", by=calcBy) calc.uCPC_(DT, Cost="Spend", Click="PeopleActioning", assignTo="uCPA", by=calcBy) } if (addSplits) { ## ------------------------------------ ## ## Add Cuts & Labels for the Cost columns # ----------------------------------- # addCutCol(DT, "CPC", "linear", asDollars=TRUE, noWarnOnChar=TRUE) addCutCol(DT, "CPA", "linear", asDollars=TRUE, noWarnOnChar=TRUE) addCutCol(DT, "CPM", "linear", asDollars=TRUE, noWarnOnChar=TRUE) addCutCol(DT, "Spend", "log", asDollars=TRUE, noWarnOnChar=TRUE, dollarsDec=0, useRoundLeft=TRUE, breaks=c(-1,5,10^seq(1, 4, by=.5))) # ----------------------------------- # } } createIndsMatrix <- function(vec, maxGroupSize=3, sortBySize=TRUE, returnIndecies=FALSE, NchooseR.limit=500, emptyVals=c("", NA), includeEmptySetIfEmptyValsFound=TRUE) { # if (!is.atomic(vec)) stop("`vec` must be atomic.\nIf you already called `createCombs` on it, do not! That call is made inside this function.") # Check if any values are emptyvals. If so, bank them, we will add them to the top of the set at the end. wh.evs <- vec %in% emptyVals evs <- vec[ wh.evs] vec <- vec[!wh.evs] ## Check if the number of combinations is too large. if ({NcR <- choose(length(vec), maxGroupSize)} > NchooseR.limit) stop("\n The total number of combinations (", NcR, ") is too large.\n\n Increase the value of `NchooseR.limit` argument and try again.\n") indsMatrix <- createCombs(vec, maxGroupSize, returnIndecies=returnIndecies) ## Convert to List indsMatrix <- unlist(apply(indsMatrix, 1, list), recursive=FALSE) indsMatrix <- unique(lapply(indsMatrix, function(x) sort(ifelse(duplicated(x), NA, x)))) ## Put back empty values if (includeEmptySetIfEmptyValsFound) indsMatrix <- c(unique(evs), indsMatrix) if (!sortBySize) return(indsMatrix) #else indsMatrix[ order(sapply(indsMatrix, length)) ] } # ------------------------------------------------------------------------------ # produceDT <- function(byCols, AddTotalFor=NULL, useDate=TRUE, DTnmsList=fbDTnms, addGVisID=!is.null(AddTotalFor)) { if(length(AddTotalFor) > 1) ## TODO: stop("Currently, cannot add totals for more than once column. That is coming soon.") # sort it, for later if(!is.null(AddTotalFor)) AddTotalFor <- sort(AddTotalFor) # grab the DT name from the list. Then check that is valid DT.nm <- DTnmsList[[ mkDTListNm(byCols, useDate) ]] if(is.null(DT.nm)) stop("\nNo DT found in the list. Check your `byCols` value, which are:\n\t ", paste0(byCols, collapse="\t "), "\n") DT <- get(DT.nm) DT.aggInfo <- c(parseAggName(DT.nm), totalsFor={if(is.null(AddTotalFor)) NA else AddTotalFor}) DT.aggInfo[["aggdBy.matched"]] <- names(DT)[match(DT.aggInfo$aggdBy, tolower(names(DT)))] DT.aggInfo[["DTname"]] <- paste(c(DT.nm, if(!is.null(AddTotalFor)) paste("_tots", AddTotalFor, sep="_")), collapse="_") # bank the key to reapply key.bak <- key(DT) # --------------------------------- # # This is all one long line to pull up another DT (same as the current, but with one less agg) # add to that one a column where every row is called "TOTAL" # naming that column with the value contained in AddTotalFor # then rbind'ing that Totals DT to the one just pulled # --------------------------------- # if (!is.null(AddTotalFor)) DT <- rbind(DT, setcolorder( cbind(setnames(as.data.table(list("TOTAL")), AddTotalFor), # adds a column whose name is the value of AddTotalFor produceDT(byCols=setdiff(byCols, AddTotalFor), AddTotalFor=NULL, useDate=useDate, DTnmsList=DTnmsList, addGVisID=FALSE) ) # close cbind , names(DT) ) # close setcolorder ) # close rbind # --------------------------------- # if (addGVisID) DT[, ".GVisID" := (.GRP), by=byCols] ## no need to reorder since (1) will probably already be ordered, (2) just using for plotting # setcolorderpt(DT, ".GVisID") if(is.null(key(DT))) setkeyv(DT, key.bak) # returns the DT invisibly, after adding the attributes setattr(DT, "aggInfo", DT.aggInfo) } # ------------------------------------------------------------------------------ # getTotalForX <- function(X, relativeTo, DTnmsList, useDate=TRUE, cleanIDcols=TRUE) { ## Note, this might have been supersceded by `getDTwithTotals` -- check code in other places # # This functions returns the DT that has X summed relative to the byCols (previously calculated, this just pulls it) # and adds a column whose value is the string "TOTAL" if (cleanIDcols) { wh <- grepl("^(Campaign|Ad)$", X, ignore.case=TRUE) X[wh] <- paste0(X[wh], "ID") } ## This is the body of it all #xx setcolorder( cbind(setnames(as.data.table(list("TOTAL")), X), # adds a column whose name is the value of X and whose value is all "TOTAL" produceDT(byCols=setdiff(relativeTo, X), AddTotalFor=NULL, useDate=useDate, DTnmsList=DTnmsList, addGVisID=FALSE) ) # close cbind #xx , names(DT) ) # close setcolorder } getDTwithTotals <- function(categ.cols.using, add.totals.for, keyby, useDate=TRUE, cleanCamp=TRUE, uniqueCheck=FALSE , removeUnknownGend=TRUE, addGVisID=TRUE, debug=FALSE, browser=debug, itercount=debug , IDColNames = c("Campaign","Ad","Label")) { # IDColNames are simply strings of colu,n names that if the column exists, so should the ID analogue. # if ("label" %in% tolower(categ.cols.using)) # browser() if (itercount) iter.debug("getDTwithTotals", coutFunc="message") if (is.list(categ.cols.using) || is.array(categ.cols.using) || !is.atomic(categ.cols.using) || !is.character(categ.cols.using)) stop("categ.cols.using should be a single atomic vector of characters.") ## list of tables to pull DT.nm <- makeAggName(categ.cols.using, date=useDate) mainDT <- get(DT.nm) ## Ordering of columns, after rbind. masterColOrder <- names(mainDT) ## Match `categ.cols.using` with the names of the mainDT. ## If any are missing, throw a warning and drop it. ## Note that it is highly unlikely to have missing names, since we are using `get(makeAggName( . ))` above categ.cols.using.matched <- masterColOrder[ pmatch(tolower(categ.cols.using), tolower(masterColOrder)) ] if (any(is.na(categ.cols.using.matched)) && !all(categ.cols.using=="")) # the second part is to allow for "", which is not a column. warning("Certain column names were not found, namely: \n", paste(categ.cols.using[is.na(categ.cols.using.matched)], collapse=" \t")) # drop any NAs and assign back to the main obj. categ.cols.using <- removeNA(categ.cols.using.matched) ## If user did not specify which columns to total, we will go through all of the ones using. (less Ad, which is semi redundant to Campaign) if (missing(add.totals.for)) add.totals.for <- setdiff(categ.cols.using, c("Ad", "ad", "AdID", "adid")) # for debugging: "early" or "pre" browser if (substr(as.character(browser),1,1) %in% c("e", "p")) browser() DT <- rbindFactorCheck( # The main DT c( list(mainDT), # A list of all the other DT's which have TOTAL columns lapply(createIndsMatrix(add.totals.for, max=length(add.totals.for), returnIndecies=TRUE), function(ind) { # Create the name from the difference in names between categ.cols.using & add.totals.for[ind] DT.nm2 <- makeAggName( setdiff(categ.cols.using, add.totals.for[ind] ), date=useDate) ## these are the columns that will be added. ColsToAdd <- removeNA(masterColOrder[match(tolower(add.totals.for[ind]), tolower(masterColOrder))]) # Before loading in the DT, we will check if we are going to make any changes to it. # If not, then we can skip this dontRet <- FALSE if (DT.nm2 == DT.nm && length(ColsToAdd)) { dontRet <- TRUE } ret <- copy(get(DT.nm2)) ## ddebugging info if (debug) { cat("\nprocessing: ", DT.nm, "\n") preprocess <- Inspect(ret, 2, cropInfo=FALSE, extractInfo=TRUE) } if (length(ColsToAdd)) ret[, c(ColsToAdd) := "TOTAL" ] ## Check if CampaignID/AdID is missing the name column or vice versa for (cc in IDColNames) { cc.id <- nameToID(cc) if (cc %in% names(ret) && ! cc.id %in% names(ret)) ret[, c(cc.id) := "TOTAL"] } # OLD - if ("Campaign" %in% names(ret) && ! "CampaignID" %in% names(ret)) # OLD - ret[, CampaignID := "TOTAL"] # OLD - if ("Ad" %in% names(ret) && ! "AdID" %in% names(ret)) # OLD - ret[, AdID := "TOTAL"] setattr(ret, "sourceDT", DT.nm) if (debug) print(cbind(rbind(preprocess, postprocess <- Inspect(ret, 2, cropInfo=FALSE, extractInfo=TRUE)), ColAdded=c("Before ", "After "))) if (dontRet) { warning ("\n\t\tWILL NOT RETURN FOR : `", DT.nm2, "` at (ind==",ind, ")\n\n") } if(isTRUE(browser)) browser() setcolorder(ret, masterColOrder) }) # // close lapply )) # // close rbindFactorCheck(c(.)) if (removeUnknownGend && "Gender" %in% names(DT)) DT <- DT[Gender != "unknown"] ## If we added a TOTAL, Drop any previous GVisID, since it is no longer accurate if (length(add.totals.for)>0 || addGVisID) suppressWarnings( DT[, c(".GVisID", "GVisID") := NULL] ) if (addGVisID) { byCols <- nameToID(categ.cols.using) ## Totals throw off the GVisID if (length(add.totals.for)>0) byCols <- unique(c(categ.cols.using, byCols)) ## set the order of sdcols to the ideal, but need to interserct, in case some cols missing sdcols <- intersect(c("Gender", "Age", "Label", "Campaign", "Ad", "LabelID", "CampaignID", "AdID"), byCols) sdcols <- c(sdcols, setdiff(byCols, sdcols)) if (!length(sdcols)) { DT[, "GVisID" := .GRP, by=byCols] } else DT[, "GVisID" := apply(.SD, 1, paste, collapse = "_"), .SDcols=sdcols] ## no need to reorder since (1) will probably already be ordered, (2) just using for plotting # setcolorderpt(DT, ".GVisID") ## need to fix for LabelID duplicates if ("LabelID" %in% sdcols || "Label" %in% categ.cols.using) { GID.tofix <- DT[, .N, by=GVisID][N>1, unique(GVisID)] setkey(DT, GVisID) DT[.(GID.tofix), GVisID := paste(GVisID, Label, sep="_"), by=Label] } } if (cleanCamp && "Campaign" %chin% names(DT)) DT[, Campaign := cleanCampName(Campaign)] ## ATTRIBUTES aggInfo <- c(aggdBy=list(if(length(categ.cols.using)>0) categ.cols.using else NA_integer_) , totdBy=list(if(length(add.totals.for)>0) add.totals.for else NA_integer_) , hasDate=useDate , mainDT.nm=DT.nm , totsDT.nm=paste(c(DT.nm, if(length(add.totals.for)) paste0("Tots4", add.totals.for)), collapse="_") ) setattr(DT, "aggInfo", aggInfo) ## Check that there are not duplicate rows. if (uniqueCheck) { if (! identical(dim(unique.data.frame(DT)), dim(DT))) warning("\n `", aggInfo$totsDT.nm , "` has none-unique rows.") } keyby <- if(missing(keyby)) key(mainDT) else keyby setkeyv(DT, keyby) } nameToID <- function(x, pat="(Campaign|Ad|Label)", append="ID", ignore.case=TRUE) { wh <- grepl(pat, x, ignore.case=ignore.case) NotThese <- grepl(paste0(append, "$"), x, ignore.case=ignore.case) wh <- wh & !NotThese x[wh] <- paste0(x[wh], append) return(x) } createNamesParsed <- function(listOfDTnms, keepOnlyThoseWithDates=TRUE, base=c("fb","agg") ) { namesParsed <- data.table(cbind(listOfDTnms), as.data.table(t(sapply(listOfDTnms, parseAggName, base=base)))) ## unlist the columns namesParsed <- namesParsed[, lapply(.SD, unlist), by=list(DT.nm=unlist(listOfDTnms))] if (keepOnlyThoseWithDates) namesParsed <- namesParsed[c(hasDate)][, hasDate := NULL] ## keep a record of the unique aggdBy values, for use in findDTnm setattr(namesParsed, "unique.aggdBy", namesParsed[, removeNA(unique(aggdBy))]) ## sort & key it setkey(namesParsed, aggdBy) } # ---------------------------------------------------- # makeAggName <- function(byVal, date, base=c("fb","agg"), makeLower=TRUE, sep="_") { if (missing(date)) { date <- TRUE mc <- as.character(as.expression(match.call())) warning("Please update code to include `date=TRUE` (no longder added by default). Call was: \n\n", mc, "\n\n") } # Drop any blank values byVal <- byVal[!byVal==""] # Determine if tolower will be used. If not, dummy func of identity tolower <- if(makeLower) tolower else identity paste0(tolower(c(base, if(date) "Date", sub("ID$", "", sort(byVal)))), collapse=sep) } mkDTListNm <- function(byVal, date, sep="_") # wrapper function to the above makeAggName(byVal=byVal, date=date, base=NULL, makeLower=FALSE, sep=sep) parseAggName <- function(nm, splitOn="_", base=c("fb","agg")) { ## escape a standalone dot if (splitOn==".") splitOn <- "\\." if(!is.atomic(nm)) stop ("`nm` must be atomic") aggdBy <- setdiff(strsplit(nm, splitOn)[[1]], base) ret <- list(aggdBy=setdiff(aggdBy, "date"), hasDate=("date" %in% aggdBy)) if (!length(ret[["aggdBy"]])) ret[["aggdBy"]] <- "" return(ret) } extractInfoFromCampaign <- function(Camp, includeOriginal=FALSE) { ## Returns a DT of parsed LabelID and Info require(stringr) ## Also will convert to Character Camp2 <- str_replace_all(Camp, ": *Label", " Label") stopifnot(is.character(Camp2)) pats <- c("\\(.*\\)", # enclosed in parenthesis. "Label ?ID *[:;, ]? *\\d+") # otherwise indicating a label ID. # Extract the pattern from Camp Camp.Parens <- str_extract_all(Camp2, pattern=ignore.case(regOr(pats))) ## Check that no Camp yielded more than one extracted value if(any( {L <- sapply(Camp.Parens, length)} > 1)) { errd <- if (length(L) < 10) paste0(Camp[L], collapse="\n\t") else paste0(c(Camp[which(L)[1:9]], " --- ---"), collapse="\n\t") stop("\n\nThe following Campaign Names have more than one parenthesis value:\n\t", errd, "\n\nPlease correct those before proceeding.\n") } # Replace not-founds with NA. Needed for the unlisting step that follows. Camp.Parens[L == 0] <- NA # convert to vector Camp.Parens <- unlist(Camp.Parens) # remove the actual parenthesis Camp.Parens <- gsub("\\(|\\)", "", Camp.Parens) # Some are missing a colon. Add it missing.col <- grep(pats[[2]], Camp.Parens, ignore.case=TRUE) Camp.Parens[missing.col] <- str_replace_all(Camp.Parens[missing.col], ignore.case("Label ?ID *[:;, ]? *"), "Label ID:") # Split on colon splat <- strsplit(Camp.Parens, ":") # Make all NA values into TWO NAs. splat[is.na(splat)] <- list(c(NA, NA)) ## all elements should have length 2 if(!all( {L <- sapply(splat, length)} <= 2)) stop("After splitting the Campaign names on ':', some have more than two elements. Please correct.") # all those with no `:` to split on, will be categorized as a Note L1 <- which(L == 1) ## --------------------------------------- ## ## this next part should not be needed if properly cleaned in fb. ## It splits on comma, for those where no colon was found commNumber <- grep(".+, ?\\d+$", splat[L1], ignore.case=TRUE) if (length(commNumber)) splat[L1][commNumber] <- strsplit(unlist(splat[L1][commNumber]), ",") # Z <- try( splat[L1][commNumber] <- strsplit(unlist(splat[L1][commNumber]), ",") ) # if (inherits(Z, "try-error")) # browser() L1 <- which(sapply(splat, length) == 1) # recompute L1 ## --------------------------------------- ## splat[L1] <- lapply(splat[L1], function(s) c(s, "-1") ) DT <- data.table(do.call(rbind, splat)) setnames(DT, c("Label", "LabelID")) # Add back the original DT[, Original := Camp] setkey(DT, "LabelID") ## Identify which are already NA, before converting to numeric wasNA <- is.na(DT[,LabelID]) DT[, LabelID := as.numeric(str_trim(LabelID))] ## clean up the info column DT[, Label := cleanWS(gsub("(, )?(Label ?)?ID", "", Label))] ## Per LabelID, grab the longest (nchar) info string. DT[LabelID != -1 # ignoring `-1` since those are non-label IDs, but not NA. , Label := Label[ which.max(nchar(Label)) ] , by=LabelID] ## If any new NAs, thats an issue that will need inspection. Throw a warning: if (any(DT[,is.na(LabelID)] & !wasNA)) warning("\n\nLabelID NAs produced when converted to numeric. Problematic Campaign names are the following:\n\n\t", paste0(DT[is.na(LabelID) & !wasNA, Original], collapse="\n\t"), "\n\n") if (!includeOriginal) DT[, Original := NULL] # Return the DT return(DT) }