# ------------------------------------------------------------------------------------------------------------------------- # # ----------------------------------------------------------------------------------------------------------------------- # # # # File Name : id Conversions.r # # Last Updated Funclist : 16 Feb 2015, 1:53 AM (Monday) # # # # Author Name : Rick Saporta # # Author Email : RSaporta@TheOrchard.com # # Author URL : www.github.com/rsaporta # # # # Packages Called : NA # # Packages Used via NS : NA # # # # ----------------------------------------------------------------------------------------------------------------------- # # # # addStoreUsesRD_ ( DT, storeidCol="storeid", newCol.nm="store_uses_royaltydollar" # # , overwrite.existing.cols=TRUE, showWarnings=TRUE ) # # addCountry.byCode_ ( DT, country_codeCol="country_code", colsToBring="country_name" ) # # addTransacInfo_ ( DT, colsToBring.in_addition_to_flags=c() # # , transacidCol=c("transactiontypeid", "transac_typeid", "transid"), abbr=TRUE # # , description=TRUE, music_vs_video=FALSE, short.description=(description && abbr) ) # # addStoreName.storeid_ ( DT, storeidCol="storeid" # # , colsToBring.from.stores=c("store_name", "store_group"), factorize_store_name=TRUE # # , refresh.DT.stores=FALSE, overwrite.existing.cols=FALSE, showWarnings=TRUE # # , storeColsToBringIn="DEPRECATED", group.included="DEPRECATED" ) # # addDateCols.periodid_ ( DT, periodCols=extract("periodid", names(DT)), newCol.nms=NULL, dropPeriodCols=FALSE # # , showWarnings=TRUE, dont.assign=FALSE, repl.for.nm=(if (is.null(newCol.nms)) "date") # # , warn.on.NA.in.periods=TRUE ) # # periodidTodate ( id, refresh.DT.periods=FALSE, execute=TRUE, cluster=getOption("db.defaultcluster.in") ) # # dateToperiodid ( date, execute=TRUE, cluster=NULL, origin=.origin ) # # dayidTodate ( dayid, execute=TRUE, cluster=NULL ) # # dateTodayid ( date, execute=TRUE, cluster=NULL ) # # # # # # # # ----------------------------------------------------------------------------------------------------------------------- # # ------------------------------------------------------------------------------------------------------------------------- # ## addMeta_() is in file: "~/git/misc/rscripts/utils/addColsFrom and addMeta.r" ## TODO: Most of the basic functions here EXCEPT periodid can be replaced with addMeta_ or addAllMeta_ ## ****************************************************************************************************************** ## ## 2015-06-01 NOTE: big difference between ## ## addCountryInfo_ and ## addLabelName.labelid_ ## ## in the handling of key(DT) ## ****************************************************************************************************************** ## addAllMeta_ <- function(DT, store_group=FALSE, buckets.store=FALSE, abbr.transacs=TRUE, description.transacs=TRUE , artist.info = TRUE , genre.info = TRUE , label.info = TRUE , product.info = TRUE , track.info = TRUE , upc_by_track=!any(c("upc", "releaseid") %in% tolower(names(DT))) , compilation.info = TRUE , label_priority=FALSE , label_country=FALSE , label_sc_group=FALSE , label_is_red=red , red=TRUE , periodIdTodate=TRUE , convertIdCols=TRUE , fill.only.missingcols=TRUE , overwrite.existing.cols=FALSE , drop.idCol="auto" , envir.for_assign=globalenv() , cluster=getOption("db.defaultcluster") ## snowflake parameters are not implemented or even mentioned in any other addMeta functions , wh=getSnowflakeWH() , dbname=getSnowflakeDB() , schema=getSnowflakeSchema() , snowflake_inuse=getOption("snowflake_inuse", default=FALSE) , showWarnings=TRUE ) { ## Calls addMeta_() sevearl times with pre-designated values if (!is.data.table(DT)) { stop("'DT' is not a data.table; it is a ", class(DT)[[1]]) } if (!missing(red) && !missing(label_is_red)) stop("'red' and 'label_is_red' are synonyms. Use only one.") idCol.candidates.ll <- list( country = c("countryid", "country_code") , store = c("storeid", "store_name") , transacs = c("transactiontypeid", "transac_typeid", "transid", "transacid", "transac_abbr", "transac_type_abbr", "transactiontypeabbr") , track = c("trackid") , release = c("releaseid", "upc", "UPC") , artist = c("artistid") , label = c("labelid") ) colsToBring.ll <- list ( country = c("countryid", "country_code") , store = c("store_name", if (store_group) "store_group", if (buckets.store) c("store_musicbucket", "store_videobucket")) , transacs = c(if (abbr.transacs) "transac_type_abbr", if (description.transacs) "transac_type") , track = c("isrc", if (upc_by_track) "upc", "track_name") , release = c("release_name", if (artist.info) "artistid", if (genre.info) "genre_name", if (label.info) "labelid", if (product.info) "product_type_id", if (compilation.info) "compilation") , artist = c("artist_name") , label = c("label_name", "label_owner", if (label_priority) "label_priority", if (label_country) "label_country", if (label_sc_group) "label_sc_group", if (label_is_red) "label_is_red") ) metas <- names(idCol.candidates.ll) %>% selfname_ for (nm in names(metas)) { meta <- metas[[nm]] # browser(text = nm) verboseMsg(verbose, "~~~~~~~~~~~~\tAdding '", nm, "' meta columns\t~~~~~~~~~~", sep="", time=FALSE) if (!any(idCol.candidates.ll[[nm]] %in% names(DT))) message("No matching ID column found in DT. No metadata to add") else addMeta_(DT=DT, DT.meta=meta, colsToBring=colsToBring.ll[[meta]], idCol.candidates=idCol.candidates.ll[[meta]] , fill.only.missingcols=fill.only.missingcols, overwrite.existing.cols=overwrite.existing.cols , drop.idCol=if (identical(drop.idCol, "auto")) nm %ni% c("release", "label", "artist") else TRUE , convertIdCols=convertIdCols , envir.for_assign=envir.for_assign , description.forWarnings=sprintf("'%s'", nm) , cluster=cluster , showWarnings=showWarnings) } if (periodIdTodate) { verboseMsg(verbose, "~~~~~~~~~~~~\tAdding '", "periodid", "' meta columns\t~~~~~~~~~~", sep="", time=FALSE) addDateCols.periodid_(DT=DT, dropPeriodCols=isTRUE(drop.idCol) || identical(drop.idCol, "auto"), verbose=FALSE, showWarnings=!missing(periodIdTodate)) } return(invisible(DT)) } addStoreUsesRD_ <- function(DT, storeidCol="storeid", newCol.nm="store_uses_royaltydollar", overwrite.existing.cols=TRUE, showWarnings=TRUE) { if (!is.data.table(DT)) { stop("'DT' is not a data.table; it is a ", class(DT)[[1]]) } if (newCol.nm != "store_uses_royaltydollar") { if ("store_uses_royaltydollar" %in% names(DT)) stop ("DT already has a column called 'store_uses_royaltydollar' but the attempted added column has a different name. Please manually remove or manually rename after this function") if (newCol.nm %in% names(DT)) stop ("DT already has a column called '", newCol.nm, "'. Please manually remove or manually rename after this function") } addStoreName.storeid_(DT=DT, colsToBring.from.stores="store_uses_royaltydollar", storeidCol=storeidCol, overwrite.existing.cols=overwrite.existing.cols) if (newCol.nm != "store_uses_royaltydollar") setnames(DT, "store_uses_royaltydollar", newCol.nm) return(invisible(DT)) } ## FULLY DEPRECATED 2015-02-01 # addCountry.byCode <- function(...) { # warning ("addCountry.byCode() has been deprecated. Add the underscore: addCountry.byCode_()") # addCountry.byCode_(...) # } addCountryInfo_ <- function(DT, colsToBring=c("country_code", "country_name", "region_group"), idCol.candidates=c("countryid", "country_code"), drop.idCol=FALSE, showWarnings=TRUE, snowflake_inuse=getOption("snowflake_inuse", FALSE), wh=getSnowflakeWH(), dbname=getSnowflakeDB()) { if (!is.data.table(DT)) { stop("'DT' is not a data.table; it is a ", class(DT)[[1]]) } DT.country <- get_dim_country(refresh=FALSE, assign=FALSE, snowflake_inuse=snowflake_inuse, wh=wh, dbname=dbname) ## Find which col to join on idCol <- intersect(idCol.candidates, names(DT)) %>% head(1) if (!length(idCol)) { verboseMsg(showWarnings, "No id col found in DT. Country meta data not added") return(invisible(DT)) } colsToBring %<>% setdiff(., idCol) firstCols <- c(names(DT)[seq(min(which(names(DT) == idCol)))], colsToBring) colsToBring <- setdiff(colsToBring, names(DT)) if (length(colsToBring)) addColsFrom_(DT, DT.country, joinCols.r=idCol, joinCols.g=ifelse(idCol=="countryid", idCol, "country_code"), colsToBring=colsToBring) setcolorderpt(DT, firstCols) ## optionally drop the idCol if (drop.idCol) { ## check if the cols that will be dropped are part of the key if (any(idCol %in% key(DT))) verboseMsg(showWarnings, "idCol is set to be dropped from DT, but is part of the key. This will result in DT not having a key. \n\nTODO: replace with brought over column") DT[, (idCol) := NULL] } return(invisible(DT)) } addCountry.byCode_ <- function(DT, country_codeCol="country_code", colsToBring="country_name", showWarnings=FALSE, snowflake_inuse=getOption("snowflake_inuse", FALSE), wh=getSnowflakeWH(), dbname=getSnowflakeDB()) { if (!is.data.table(DT)) { stop("'DT' is not a data.table; it is a ", class(DT)[[1]]) } is.char_of_length1(country_codeCol) if (country_codeCol %ni% names(DT)) { verboseMsg(showWarnings, "country_codeCol '", country_codeCol, "' is not a column inDT. Country meta data not added") return(invisible(DT)) } if (!exists("DT.country")) DT.country <- get_dim_country(refresh=FALSE, assign=FALSE, snowflake_inuse=snowflake_inuse, wh=wh, dbname=dbname) DT.country <- copy(DT.country) is.factor.DT.country <- is.factor(DT.country$country_code) is.factor.DT <- is.factor(DT$country_code) if (is.factor.DT.country) { levs.DT.country <- levels(DT.country$country_code) DT.country[, country_code := as.character(country_code)] on.exit(DT.country[, country_code := factor(country_code, levels=levs.DT.country)], add=TRUE) } if (is.factor.DT) { levs.DT <- levels(DT$country_code) DT[, country_code := as.character(country_code)] on.exit(DT[, country_code := factor(country_code, levels=levs.DT)], add=TRUE) } firstCols <- c(names(DT)[seq(min(which(names(DT) == country_codeCol)))], colsToBring) %>% unique colsToBring <- setdiff(colsToBring, names(DT)) if (length(colsToBring)) addColsFrom_(DT, DT.country, joinCols.r=country_codeCol, joinCols.g=ifelse(country_codeCol=="countryid", country_codeCol, "country_code"), colsToBring=colsToBring) setcolorderpt(DT, firstCols) return(invisible(DT)) } addTransacInfo_ <- function(DT , colsToBring.in_addition_to_flags = c() , transacidCol=c("transactiontypeid", "transac_typeid", "transid") , abbr=TRUE, description=TRUE, music_vs_video=FALSE , short.description=(description && abbr) , refresh=TRUE , snowflake_inuse=getOption("snowflake_inuse", FALSE), wh=getSnowflakeWH(), dbname=getSnowflakeDB() ) { if (!is.data.table(DT)) { stop("'DT' is not a data.table; it is a ", class(DT)[[1]]) } if (!description && !abbr) { warning ("Nothing to add") return(invisible(DT)) } if (!is.data.table(DT)) { warning ("DT is not a data.table") return(invisible(DT)) } if (missing(transacidCol)) { if (length(matched <- unlist(sapply(transacidCol, extract, DT))) == 1) transacidCol <- matched else transacidCol <- transacidCol[[1]] } if (length(transacidCol) > 1) stop ("transacidCol must have length exactly 1") if (!transacidCol %in% names(DT)) { possible <- extract("trans", DT) stop ("'", transacidCol, "' is not a name in DT\nHINT: possible column names: ", commaSep(possible)) } DT.transacs <- get_dim_transacs(refresh=refresh) key.bak <- key(DT) on.exit(expr=setkeyIfNot(DT, key.bak, verbose=FALSE), add=TRUE) setkeyv(DT, transacidCol) setkeyv(DT.transacs, "transac_typeid") ## TODO: create a j expr and join only one time ## better yet, use addCols if (isTRUE(abbr)) DT[DT.transacs, ("transac_type_abbr") := i.transac_type_abbr, allow=TRUE] if (isTRUE(description)) { DT[DT.transacs, ("transac_type") := i.transac_type, allow=TRUE] if ("transac_type_short" %in% names(DT.transacs) && isTRUE(short.description)) ## we check for isTRUE(abbr) because presumably, if the user deslects that one, they want only one column DT[DT.transacs, ("transac_type_short") := i.transac_type_short, allow=TRUE] } if (isTRUE(music_vs_video)) DT[DT.transacs, ("music_vs_video_by_transac") := i.music_vs_video_by_transac, allow=TRUE] setkeyIfNot(DT, key.bak, verbose=FALSE, organize=FALSE, superset.ok=FALSE) } addLabelName.labelid_ <- function(DT , idCol="labelid" , colsToBring=c("label_name") # = c("label_name", "label_owner", "label_sc_group") , factorize_label_name=TRUE , drop.idCol=FALSE , refresh.DT.labels=FALSE, overwrite.existing.cols=FALSE, showWarnings=TRUE ## DEPRECATED ARGUMENTS: , labelidCol = "DEPRECATED" , labelColsToBringIn="DEPRECATED", group.included="DEPRECATED", colsToBring.from.labels="DEPRECATED" , snowflake_inuse=getOption("snowflake_inuse", FALSE), wh=getSnowflakeWH(), dbname=getSnowflakeDB() ) { ## TODO: Make the j= programattic if (!is.data.table(DT)) { stop("'DT' is not a data.table; it is a ", class(DT)[[1]]) } ### -------------------- DEPRECATED PARAMS CLEAN UP ---------------------------------### ### -------------------- DEPRECATED PARAMS CLEAN UP ---------------------------------### if (!missing(labelidCol)) { if (!missing(idCol)) stop ("Both idCol AND labelidCol -- why? What was the intention? labelidCol has been deprecated in favor of idCol") idCol <- labelidCol warning ("labelidCol has been deprecated from addLabelName.labelid_(). use idCol instead", call.=FALSE) } if (!missing(labelColsToBringIn) || !missing(group.included) || !missing(colsToBring.from.labels)) stop ("'colsToBring.from.labels', 'labelColsToBringIn' and 'group.included' have been DEPRECATED from addLabelName.labelid_() \nUse 'colsToBring' instead.") ## -------------------------------- ## Find which col to join on idCol <- intersect(idCol, names(DT)) %>% head(1) if (!length(idCol)) { verboseMsg(showWarnings, "No id col found in DT. Label meta data not added") return(invisible(DT)) } if (!exists("DT.labels")) DT.labels <- get_dim_label(refresh=refresh.DT.labels, snowflake_inuse=snowflake_inuse, wh=wh, dbname=dbname) if (any(colsToBring %ni% names(DT.labels))) stop ("Some colsToBring are not in DT.labels.\nHINT: Available options are ", pasteQand(names(DT.labels))) ## Bank the key key.bak <- key(DT) on.exit(expr=setkeyIfNot(DT, key.bak, verbose=FALSE), add=TRUE) colsToBring %<>% setdiff(., idCol) ## Check if any of the columns are present already if (any(colsToBring %in% names(DT))) { if (!isTRUE(overwrite.existing.cols)) stop ("Some columns fom colsToBring are already in the DT\nHINT: set overwrite.existing.cols=TRUE to proceed past this check") if (showWarnings) warning ("Some columns fom colsToBring are already in the DT\nHINT: set showWarnings=FALSE to not see this message") ## CANNOT SIMPLY OVERWRITE -- must drop. (In case some rows in DT dont have a match in DT.labels) suppressWarnings(DT[, (colsToBring) := NULL]) } # ---------------------------- # copied from addCountryInfo_ # ---------------------------- # ## if colsToBring is not explicit, do not try to bring over to id col # if (missing(colsToBring)) firstCols <- c(names(DT)[seq(min(which(names(DT) == idCol)))], colsToBring) colsToBring <- setdiff(colsToBring, names(DT)) if (length(colsToBring)) addColsFrom_(DT, DT.labels, joinCols.r=idCol, joinCols.g="labelid", colsToBring=colsToBring) setcolorderpt(DT, firstCols) ## optionally drop the idCol if (drop.idCol) { if (any(idCol %in% key.bak)) { verboseMsg(showWarnings, "idCol was/were in key(DT). The key will be placed back without that column.\n\nTODO: replace with brought over column") key.bak %<>% setdiff(., idCol) } DT[, (idCol) := NULL] } return(invisible(DT)) # ---------------------------- ## EVERYTHING AFTER THIS POINT IS THE OLD VERSION ## EVERYTHING AFTER THIS POINT IS THE OLD VERSION # old: setkeyv(DT, idCol) # old: setkeyv(DT.labels, "labelid") # old: # old: ## Wrap in try() in case of any error, still able to put key back before failing # old: caught <- try({ # old: j.expr <- sprintf("(colsToBring) := list(%s)", commaSep(sprintf("`i.%s`", colsToBring))) # old: DT[DT.labels, j = eval(parse(text=j.expr)), allow.cartesian=TRUE] # old: # old: ## Check that the columns made it over. If not, this is probably do to no-matches between the two tables # old: if (any(colsToBring %ni% names(DT))) { # old: rows.matched <- nrow(DT[DT.labels, allow=TRUE]) # old: warning ("\nSome columns of colsToBring did *NOT* make it into the DT when calling addStoreName.labelid_()\nHINT: ", if (rows.matched == 0) "This is likely because DT[DT.labels] had 0 rows (ie, no overlap in the key values)" else "This is **NOT** dues to unmatched values, since DT[DT.labels] had ", rows.matched, " rows") # old: } # old: # old: if (factorize_label_name && "label_name" %in% colsToBring) # old: # makeStoresFactor_(DT) # old: DT[, label_name := factor(label_name)] # old: # old: ## 'return' TRUE # old: TRUE # old: }, silent=TRUE) # old: # old: ## PUT THE KEY BACK # old: setkeyIfNot(DT, key.bak, verbose=FALSE, organize=FALSE, superset.ok=FALSE) # old: # old: ## Check for errors # old: if (isErr(caught)) # old: stop ("Internal error in addStoreName.labelid_() Error was:\n", as.character(caught)) # old: # old: return(invisible(DT)) } addStoreName.storeid_ <- function(DT , storeidCol="storeid" , colsToBring.from.stores=c("store_name", "store_group") , factorize_store_name=TRUE , refresh.DT.stores=FALSE, overwrite.existing.cols=FALSE, showWarnings=TRUE ## DEPRECATED ARGUMENTS: , storeColsToBringIn="DEPRECATED", group.included="DEPRECATED" , snowflake_inuse=getOption("snowflake_inuse", FALSE), wh=getSnowflakeWH(), dbname=getSnowflakeDB() ) { ## TODO: Make the j= programattic if (!is.data.table(DT)) { stop("'DT' is not a data.table; it is a ", class(DT)[[1]]) } if (!missing(storeColsToBringIn) || !missing(group.included)) stop ("storeColsToBringIn and group.included have been DEPRECATED from addStoreName.storeid_() \nUse 'colsToBring.from.stores' instead.") if (!exists("DT.stores")) DT.stores <- get_dim_store(refresh=refresh.DT.stores, snowflake_inuse=snowflake_inuse, wh=wh, dbname=dbname) if (any(colsToBring.from.stores %ni% names(DT.stores))) stop ("Some colsToBring.from.stores are not in DT.stores.\nHINT: Available options are ", pasteQand(names(DT.stores))) ## Bank the key key.bak <- key(DT) on.exit(expr=setkeyIfNot(DT, key.bak, verbose=FALSE), add=TRUE) ## Check if any of the columns are present already if (any(colsToBring.from.stores %in% names(DT))) { if (!isTRUE(overwrite.existing.cols)) stop ("Some columns fom colsToBring.from.stores are already in the DT\nHINT: set overwrite.existing.cols=TRUE to proceed past this check") if (showWarnings) warning ("Some columns fom colsToBring.from.stores are already in the DT\nHINT: set showWarnings=FALSE to not see this message") suppressWarnings(DT[, (colsToBring.from.stores) := NULL]) } setkeyv(DT, storeidCol) setkeyv(DT.stores, "storeid") ## Wrap in try() in case of any error, still able to put key back before failing caught <- try({ j.expr <- sprintf("(colsToBring.from.stores) := list(%s)", commaSep(sprintf("`i.%s`", colsToBring.from.stores))) DT[DT.stores, j = eval(parse(text=j.expr)), allow.cartesian=TRUE] ## Check that the columns made it over. If not, this is probably do to no-matches between the two tables if (any(colsToBring.from.stores %ni% names(DT))) { rows.matched <- nrow(DT[DT.stores, allow=TRUE]) warning ("\nSome columns of colsToBring.from.stores did *NOT* make it into the DT when calling addStoreName.storeid_()\nHINT: ", if (rows.matched == 0) "This is likely because DT[DT.stores] had 0 rows (ie, no overlap in the key values)" else "This is **NOT** dues to unmatched values, since DT[DT.stores] had ", rows.matched, " rows") } if (factorize_store_name && "store_name" %in% colsToBring.from.stores) makeStoresFactor_(DT) ## 'return' TRUE TRUE }, silent=TRUE) ## PUT THE KEY BACK setkeyIfNot(DT, key.bak, verbose=FALSE, organize=FALSE, superset.ok=FALSE) ## Check for errors if (isErr(caught)) stop ("Internal error in addStoreName.storeid_() Error was:\n", as.character(caught)) return(invisible(DT)) } addDateCols.periodid_ <- function(DT, periodCols=extract("periodid", names(DT)), newCol.nms=NULL, dropPeriodCols=FALSE, showWarnings=TRUE, dont.assign=FALSE , overwrite.existing.cols=FALSE , repl.for.nm=(if (is.null(newCol.nms)) "date"), warn.on.NA.in.periods=TRUE, refresh.DT.periods=FALSE , cluster=getOption("db.defaultcluster.in") , snowflake_inuse=getOption("snowflake_inuse", FALSE) , wh=getSnowflakeWH(), dbname=getSnowflakeDB() , verbose=TRUE) { if (!is.data.table(DT)) { stop("'DT' is not a data.table; it is a ", class(DT)[[1]]) } MEM <- Inspect(DT, simple=TRUE)$mem if (!length(DT) || !nrow(DT)) { if (showWarnings) warning("DT has no length or no rows. No changes made") return(invisible(DT)) } if (!length(periodCols)) { if (showWarnings) warning("There are no periodCols No changes made") return(invisible(DT)) } ## DEBUGGING if (MEM != Inspect(DT, simple=TRUE)$mem) stop("478") if (!is.null(newCol.nms) && !is.null(repl.for.nm)) stop ("Only one of 'newCol.nms' and 'repl.for.nm' may be used") ## Create new names, or confirm they have same length if (missing(newCol.nms) || is.null(newCol.nms)) { repl <- paste0("\\1", repl.for.nm) newCol.nms <- gsub("(_?)period(id)?", repl, periodCols) } else if (length (newCol.nms) != length(periodCols)) { stop ("newCol.nms and periodCols have differing lengths") } ## DEBUGGING if (MEM != Inspect(DT, simple=TRUE)$mem) stop("493") ## Confirm that newCol.nms are not already in DT. If so, fail. if (any(wh.exist <- newCol.nms %in% names(DT))) { msg <- warningCols("The following columns already exist in DT", newCol.nms[wh.exist], post="HINT: Drop them manually before executing addDateCols.periodid_() to overwrite") if (!overwrite.existing.cols) stop (msg) if (showWarnings) warning(msg, call.=TRUE) } ## The names of newCol.nms should be the same as periodCols ## TODO: Reorder newCol.nms according to periodCols if (!is.null(names(newCol.nms)) && !identical(names(newCol.nms), periodCols)) stop ("The names of newCol.nms should be the periodCols") else names(newCol.nms) <- periodCols ## DEBUGGING if (MEM != Inspect(DT, simple=TRUE)$mem) stop("512") ## Confirm all columns are numeric numericCols <- unlist(canBeNumeric(DT[, periodCols, with=FALSE])) if (any(!numericCols)) { if (showWarnings) warning(warningCols("Some columns appear not to be numeric", nwhich(!numericCols))) periodCols <- periodCols[numericCols] newCol.nms <- newCol.nms[numericCols] } browser(expr = inDebugMode(c("addDateCols.periodid_", "addDateCols")), text="in addDateCols.periodid_ middle") ## DEBUGGING if (MEM != Inspect(DT, simple=TRUE)$mem) stop("527") ## TODO 20141215 - switch to DT.periods <- get_dim_period() ## query the DB for period IDs pids <- unlist(DT[, periodCols, with=FALSE], use.names=FALSE) ## ERROR CHECK -- make sure there are no NA's in the period ids (remove if yes) and make sure the pids have some lenth { if (any(is.na(pids))) { if (all(is.na(pids))) stop ("All the period ids are NA - do not know how to proceed") else if (warn.on.NA.in.periods) warning("There are NAs in the period ids") pids <- removeNA(pids) } if (!length(pids)) stop ("There is no length to pids (periodid's)\ HINT: try running again with debugOn('addDateCols')") } ## Get the DT.periods, first without refreshing. Only refresh if some periodids dont fit DT.periods <- get_dim_period(assign.to.envir=FALSE, cluster=cluster, wh=wh, dbname=dbname, snowflake_inuse=snowflake_inuse, verbose=verbose) if (any (pids > max(DT.periods$periodid, na.rm = TRUE))) { warning ("Some periodid's to replace are GREATER THAN the max periodid in DT.periods. NAs will be introduced\n\nHINT: This could be due to pulling the data froma a different cluster than DT.periods\n Try setting\n refresh.DT.periods=TRUE") } if (!isInDateRange(DT.periods, "periodid", minDate=minn(pids), maxDate=maxn(pids), showWarnings=TRUE)) DT.periods <- get_dim_period(assign.to.envir=FALSE, refresh=TRUE, cluster=cluster, wh=wh, dbname=dbname, snowflake_inuse=snowflake_inuse, verbose=verbose) setkeyIfNot(DT.periods, periodid, verbose=FALSE) # pidsClause <- ifelse(length(pids) > 10, paste0(">= ", min(pids)), paste0("in (", commaSep(pids), ")")) # qry.pids <- setQry(sprintf("SELECT periodid, CAST(perioddate AS date) AS \"date\" FROM bi.period_view WHERE periodid %s", pidsClause)) # ## Check if already exist and has necessary info, so sa to not have to repull # if (!exists("DT.pids") || !(DT.pids %cont% "periodid") || any(pids %ni% DT.pids$periodid)) # DT.pids <- runQry(qry.pids, dont.setkey=TRUE, verbose=FALSE) # else # dont.assign <- TRUE # setkeyIfNot(DT.pids, periodid, verbose=FALSE) ## assign if repulled # if (!dont.assign) # assign("DT.pids", value=DT.pids, envir=globalenv()) ## Bank the key key.bak <- key(DT) on.exit(setkeyIfNot(DT, key.bak, verbose=FALSE, organize=FALSE)) ## Change the keys to new col if dropping periodcol if (dropPeriodCols && any(wh.key <- key.bak %in% names(newCol.nms))) key.bak[wh.key] <- newCol.nms[key.bak[wh.key]] if (MEM != Inspect(DT, simple=TRUE)$mem) stop("285") ## Add the columns first DT[, c(newCol.nms[periodCols]) := as.Date(NA, origin=.origin)] if (MEM != Inspect(DT, simple=TRUE)$mem) stop("289") ## Merge in for (col in periodCols) { setkeyIfNot(DT, col, verbose=FALSE, organize=FALSE) ## 2015-01-24 Added allow=TRUE ## I'm concerned that this is even needed. (The "additional" rows are ## those for which period is not in DT, ie periods 1:156 or so) ## I think this is a bug in data.table ## NOTE that DT.periods will refresh (depending on criteria above), in which case there was no cartesian join anyway DT[DT.periods, (newCol.nms[[col]]) := as.Date(perioddate), allow=TRUE] } if (MEM != Inspect(DT, simple=TRUE)$mem) stop("302") if (dropPeriodCols && all(newCol.nms %in% names(DT))) DT[, (names(newCol.nms)) := NULL] ## Put the key back setkeyIfNot(DT, key.bak, verbose=FALSE, organize=FALSE) return(invisible(DT)) } periodidTodate <- function(id, refresh.DT.periods=FALSE, execute=TRUE, cluster=getOption("db.defaultcluster.in") , wh=getSnowflakeWH() , dbname=getSnowflakeDB() , snowflake_inuse=getOption("snowflake_inuse", default=FALSE) , verbose=TRUE ) { if (is.numeric(execute)) stop("'execute' should be a logical value.\n\n HINT: did you forget to wrap 'id' in c() ?") if (any(is.na(id))) warning ("There are NAs in 'id'.") if (!length(id)) stop ("'id' has no length") if (is.factor(id)) id.integer <- as.integer(as.character(id)) else if (!is.integer(id)) id.integer <- as.integer(id) else id.integer <- id ## Warn if anything was lost in the conversion if (!all(id.integer == id)) { warning ("'id' was not an integer, and upon coercian to integer, some data was lost") } # if (length(id) > 1) # qry <- paste0("SELECT perioddate FROM bi.period_view WHERE periodid in (", commaSep(id), ")") # else # qry <- paste0("SELECT perioddate FROM bi.period_view WHERE periodid = ", id) # # if (!execute) # return(paste0("(", qry, ")")) # # qres <- runQry(qry, verbose=FALSE, cluster=cluster) DT.periods <- get_dim_period(refresh=refresh.DT.periods, cluster=cluster, wh=wh, dbname=dbname, snowflake_inuse=snowflake_inuse) setkeyIfNot(DT.periods, periodid, verbose=FALSE) ret <- DT.periods[.(id.integer)][, as.Date(perioddate)] data.table::setattr(ret, "names", as.character(id)) ## Note that even if the ids are missing, NAs will be returned if (!length(ret)) stop ("\nInternal error at periodidTodate()\nNo results returned for id = ", gsub("L(, |\\)$)", "\\1", capture.output(dput(id))), "\n\nHINT: Check DT.periods and see if those IDs are there") ## Check for *introduced* NAs if (!identical(unname(is.na(ret)), unname(is.na(id)))) warning ("NAs were produced due to some values of id not matching to a date.") return(ret) } dateToperiodid <- function(date, execute=TRUE, cluster=NULL, origin=.origin, snowflake_inuse=getOption("snowflake_inuse", FALSE)) { if (isTRUE(snowflake_inuse)) stop ("snowflake_inuse is NOT executed for this function") ## round the date down date <- unlist(date, use.names=FALSE) ## Do NOT convert strings that contain these SQL keywords convert <- sapply(date, function(x) !(is.character(x) && grepl("(SELECT|FROM|MAX|MIN)", date, ignore.case=TRUE))) if (any(convert)) date[convert] <- format(as.Date(date[convert], origin=origin), "%Y-%m-01") if (is.numeric(execute) || inherits(execute, "Date") || is.character(execute)) stop("'execute' should be a logical value.\n\n HINT: did you forget to wrap date in c() ?") if (any(is.na(date))) stop ("There are NAs in 'date'. NAs are not allowed") if (!length(date)) stop ("'date' has no length") qry <- paste0("SELECT periodid FROM bi.period_view WHERE perioddate ", ifelse(length(date) > 1, "in ", "= "), pasteQ(date)) if (!execute) return(paste0("(", qry, ")")) qres <- runQry(qry, verbose=FALSE, cluster=cluster) if (!nrow(qres)) { warning ("No results returned for date = ", capture.output(dput(date))) return(invisible(NA)) } if ("periodid" %ni% names(qres)) { warning ("something went wrong with dateToperiodid, periodid is not in names(qres)\nQuery ran is: \n\n ", qry) return(invisible(NA)) } ret <- as.numeric(qres[["periodid"]]) return(setNames(obj=ret, as.character(date))) } dayidTodate <- function(dayid, execute=TRUE, cluster=NULL, snowflake_inuse=getOption("snowflake_inuse", FALSE)) { if (isTRUE(snowflake_inuse)) stop ("snowflake_inuse is NOT executed for this function --- did you mean to run setDBall(cluster = ___ ) ?") if (is.numeric(execute)) stop("'execute' should be a logical value.\n\n HINT: did you forget to wrap dayid in c() ?") if (any(is.na(dayid))) stop ("There are NAs in 'dayid'. NAs are not allowed") if (!length(dayid)) stop ("'dayid' has no length") if (length(dayid) > 1) qry <- paste0("SELECT displaydate FROM production.dim_day WHERE dayid in (", commaSep(dayid), ")") else qry <- paste0("SELECT displaydate FROM production.dim_day WHERE dayid = ", dayid) if (!execute) return(paste0("(", qry, ")")) qres <- runQry(qry, verbose=FALSE, cluster=cluster) if (!nrow(qres)) { warning ("No results returned for dayid = ", capture.output(dput(dayid))) return(invisible(NA)) } if ("displaydate" %ni% names(qres)) { warning ("something went wrong with dayidTodate, 'displaydate' is not in names(qres)\nQuery ran is: \n\n ", qry) return(invisible(NA)) } ret <- as.Date(qres[["displaydate"]]) return(setNames(obj=ret, as.character(dayid))) } dateTodayid <- function(date, execute=TRUE, cluster=NULL, snowflake_inuse=getOption("snowflake_inuse", FALSE)) { if (isTRUE(snowflake_inuse)) stop ("snowflake_inuse is NOT executed for this function") date <- sapply(date, function(x) as.character(x)) if (is.numeric(execute) || inherits(execute, "Date") || is.character(execute)) stop("'execute' should be a logical value.\n\n HINT: did you forget to wrap date in c() ?") if (any(is.na(date))) stop ("There are NAs in 'date'. NAs are not allowed") if (!length(date)) stop ("'date' has no length") qry <- paste0("SELECT dayid FROM production.dim_day WHERE displaydate ", ifelse(length(date) > 1, "in ", "= "), pasteQ(date)) if (!execute) return(paste0("(", qry, ")")) qres <- runQry(qry, verbose=FALSE, cluster=cluster) if (!nrow(qres)) { warning ("No results returned for date = ", capture.output(dput(date))) return(invisible(NA)) } if ("dayid" %ni% names(qres)) { warning ("something went wrong with dateTodayid, dayid is not in names(qres)\nQuery ran is: \n\n ", qry) return(invisible(NA)) } ret <- as.numeric(qres[["dayid"]]) return(setNames(obj=ret, as.character(date))) }