Displayr / flipAPI / 877

pending completion

Build # 877

Build Type

push

travis-ci-com

Committed by

web-flow

Commit Message

Add functions for sending data to Factbase (#15)

Run Details

89 of 89 new or added lines in 1 file covered. (100.0%)

200 of 650 relevant lines covered (30.77%)

1.8 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

0.0

/R/Factbase.R

#' Upload a metric to Factbase.
#'
#' @param data A data.frame with at least three columns, being (in order) for
#'   * measurements (must be numeric).  The column name will name the metric.
#'   * date/time (Data Science to specify the formats that normal users would expect to be supported
#'     in where there will be a lot of data; supply automatic conversion if you think that is
#'     reasonable).  The column name is unimportant.
#'   * dimension 1 (coerced to character).  The column name will be used for the dimension name.
#'   * …
#'   * dimension n
#' @param token A guid that identifies and authenticates the request.  Talk to Oliver if you need
#'   one of these.
#' @param mode One of "replace_all", "append" or "append_or_update" See comments for
#'   FactPostUpdateType.
#' @param aggregation One of "none", "minimum", "maximum", "sum", "average", "first", "last".
#' @param definition A detailed explanation of the meaning and derivation of the metric.
#' @param hyperlink A link to a web page where more can be read about the metric.
#' @return The value of `data` that was passed in, so caller can see data uploaded if this is the
#'   last call in R code
#'
#' @importFrom RJSONIO toJSON
#' @export
UploadMetricToFactbase <- function(data, token, mode="replace_all", aggregation="sum",
        definition=NULL, hyperlink=NULL) {
    if (!is.data.frame(data))
        # Include the data in the error message because often this will be an SQL error,
        # returned instead of a data.frame.  This makes it easier for users to spot the problem.
        stop(paste("'data' must be a data.frame, but got", format(data)))
    if (length(is.data.frame) == 0)
        stop("There must be at least one column in 'data'")
    if (!is.numeric(data[[1]]))
        stop("The first column in 'data' must contain the metric, and be numeric")
    if (!(aggregation %in% c("none", "minimum", "maximum", "sum", "average", "first", "last")))
        stop(paste("Unknown 'aggregation':", aggregation))

    # Build dimensions.
    original_data <- data
    data <- c(data)  # avoid modifying caller's data.frame
    n <- names(data)
    metric_name <- n[1]
    if (n[2] == "_When") {
        dimension_columns <- 3:length(n)
        time_dimension <- list(
            list(
                name="_When",
                dimensionType="in_data",
                valueType="datetime"
            )
        )
        if (inherits(data[[2]], "Date"))
            data[[2]] <- as.POSIXct(data[[2]])
        if (!inherits(data[[2]], "POSIXct"))
            stop("The _When column must be of class POSIXct")
        data[[2]] <- as.numeric(data[[2]]) * 1000  # convert from POSIXct (seconds since 1970)
                                                  # to JavaScript (ms since 1970)
    } else {
        dimension_columns <- 2:length(n)
        time_dimension <- list()
    }
    dimension_data <- lapply(data[dimension_columns], function(column) { as.character(column)})
    dimension_names <- n[dimension_columns]
    text_dimensions <- mapply(function(v, name) {
        list(
            name=name,
            dimensionType="in_data",
            valueType="text")
    }, dimension_data, dimension_names, SIMPLIFY=FALSE, USE.NAMES=FALSE)
    dimensions <- c(time_dimension, text_dimensions)

    # Structure observations as a list of lists for toJSON.
    list_for_observation <- function(...) {
        list(...)
    }
    mapply_args <- c(list_for_observation, unname(data), list(SIMPLIFY=FALSE, USE.NAMES=FALSE))
    observations <- do.call("mapply", mapply_args)

    # Make HTTP request
    metric <- list(
        name=metric_name,
        valueType="real",
        aggregation=aggregation
    )
    if (!is.null(definition))
        metric$definition <- definition
    if (!is.null(hyperlink))
        metric$hyperlink <- hyperlink
    body <- toJSON(list(
        metric=metric,
        update=mode,
        dimensions=dimensions,
        data=observations
    ), digits=15, .na="null")  # May need in future: .inf="null"
    post_to_factbase(body, token)

    original_data
}

#' @importFrom httr POST timeout add_headers content
post_to_factbase <- function(body, token) {
    message(paste0("POSTing ", nchar(body), " characters from ", Sys.info()["nodename"]))
    url <- "https://factbase.azurewebsites.net/fact"
    r <- POST(url, body = body, encode = "json",
        add_headers(`x-facttoken` = token), timeout(3600))
    if (r$status_code != 200)
        stop(paste0(r$status_code, ": ", content(r, "text")))
}

#' Upload a relationship to Factbase.
#'
#' @param data A data.frame with at least two columns, each of which should be coerced to character
#'   vectors.  The first column is the dimension we are mapping from.  Subsequent columns contain
#'   labels in dimensions that we are mapping to.  The names of these columns to be used as the
#'   names of these dimensions.
#' @param token A guid that identifies and authenticates the request.  Talk to Oliver if you need
#'   one of these.
#' @param mode One of "replace_all", "append" or "append_or_update" See comments for
#'   FactPostUpdateType.
#'
#' @return The value of `data` that was passed in, so caller can see data uploaded if this is the
#'   last call in R code
#'
#' @importFrom RJSONIO toJSON
#' @export
UploadRelationshipToFactbase <- function(data, token, mode="replace_all") {
    if (!is.data.frame(data))
        # Include the data in the error message because often this will be an SQL error,
        # returned instead of a data.frame.  This makes it easier for users to spot the problem.
        stop(paste("'data' must be a data.frame, but got", format(data)))
    if (length(data) < 2)
        stop("There must be at least two columns in 'data'")
    original_data <- data

    # Build dimensions.
    dimensions <- mapply(function(v, name, i) {
        list(
            name=name,
            dimensionType="in_data",
            valueType="text")
    }, data, names(data), SIMPLIFY=FALSE, USE.NAMES=FALSE)
    dimensions[[1]]$unique <- TRUE

    # Coerce all to character vectors.
    data <- lapply(data, function(column) { as.character(column) })

    # Structure observations as a list of lists for toJSON.
    list_for_observation <- function(...) {
        list(...)
    }
    mapply_args <- c(list_for_observation, unname(data), list(SIMPLIFY=FALSE, USE.NAMES=FALSE))
    observations <- do.call("mapply", mapply_args)

    # Make HTTP request
    body <- toJSON(list(
        relationship=list(
            type="many_to_one"
        ),
        update=mode,
        dimensions=dimensions,
        data=observations
    ), digits=15, .na="null")
    message(paste("Dimensions:", paste(vapply(dimensions, function(d) {d$name}, ""),
        collapse=", ")))
    post_to_factbase(body, token)

    original_data  # so caller can see data uploaded if this is the last call in R code
}

1	#' Upload a metric to Factbase.
2	#'
3	#' @param data A data.frame with at least three columns, being (in order) for
4	#' * measurements (must be numeric). The column name will name the metric.
5	#' * date/time (Data Science to specify the formats that normal users would expect to be supported
6	#' in where there will be a lot of data; supply automatic conversion if you think that is
7	#' reasonable). The column name is unimportant.
8	#' * dimension 1 (coerced to character). The column name will be used for the dimension name.
9	#' * …
10	#' * dimension n
11	#' @param token A guid that identifies and authenticates the request. Talk to Oliver if you need
12	#' one of these.
13	#' @param mode One of "replace_all", "append" or "append_or_update" See comments for
14	#' FactPostUpdateType.
15	#' @param aggregation One of "none", "minimum", "maximum", "sum", "average", "first", "last".
16	#' @param definition A detailed explanation of the meaning and derivation of the metric.
17	#' @param hyperlink A link to a web page where more can be read about the metric.
18	#' @return The value of `data` that was passed in, so caller can see data uploaded if this is the
19	#' last call in R code
20	#'
21	#' @importFrom RJSONIO toJSON
22	#' @export
23	UploadMetricToFactbase <- function(data, token, mode="replace_all", aggregation="sum",
24	definition=NULL, hyperlink=NULL) {
25	if (!is.data.frame(data))	×
26	# Include the data in the error message because often this will be an SQL error,
27	# returned instead of a data.frame. This makes it easier for users to spot the problem.
28	stop(paste("'data' must be a data.frame, but got", format(data)))	×
29	if (length(is.data.frame) == 0)	×
30	stop("There must be at least one column in 'data'")	×
31	if (!is.numeric(data[[1]]))	×
32	stop("The first column in 'data' must contain the metric, and be numeric")	×
33	if (!(aggregation %in% c("none", "minimum", "maximum", "sum", "average", "first", "last")))	×
34	stop(paste("Unknown 'aggregation':", aggregation))	×
35
36	# Build dimensions.
37	original_data <- data	×
38	data <- c(data) # avoid modifying caller's data.frame	×
39	n <- names(data)	×
40	metric_name <- n[1]	×
41	if (n[2] == "_When") {	×
42	dimension_columns <- 3:length(n)	×
43	time_dimension <- list(	×
44	list(	×
45	name="_When",	×
46	dimensionType="in_data",	×
47	valueType="datetime"	×
48	)
49	)
50	if (inherits(data[[2]], "Date"))	×
51	data[[2]] <- as.POSIXct(data[[2]])	×
52	if (!inherits(data[[2]], "POSIXct"))	×
53	stop("The _When column must be of class POSIXct")	×
54	data[[2]] <- as.numeric(data[[2]]) * 1000 # convert from POSIXct (seconds since 1970)	×
55	# to JavaScript (ms since 1970)
56	} else {
57	dimension_columns <- 2:length(n)	×
58	time_dimension <- list()	×
59	}
60	dimension_data <- lapply(data[dimension_columns], function(column) { as.character(column)})	×
61	dimension_names <- n[dimension_columns]	×
62	text_dimensions <- mapply(function(v, name) {	×
63	list(	×
64	name=name,	×
65	dimensionType="in_data",	×
66	valueType="text")	×
67	}, dimension_data, dimension_names, SIMPLIFY=FALSE, USE.NAMES=FALSE)	×
68	dimensions <- c(time_dimension, text_dimensions)	×
69
70	# Structure observations as a list of lists for toJSON.
71	list_for_observation <- function(...) {	×
72	list(...)	×
73	}
74	mapply_args <- c(list_for_observation, unname(data), list(SIMPLIFY=FALSE, USE.NAMES=FALSE))	×
75	observations <- do.call("mapply", mapply_args)	×
76
77	# Make HTTP request
78	metric <- list(	×
79	name=metric_name,	×
80	valueType="real",	×
81	aggregation=aggregation	×
82	)
83	if (!is.null(definition))	×
84	metric$definition <- definition	×
85	if (!is.null(hyperlink))	×
86	metric$hyperlink <- hyperlink	×
87	body <- toJSON(list(	×
88	metric=metric,	×
89	update=mode,	×
90	dimensions=dimensions,	×
91	data=observations	×
92	), digits=15, .na="null") # May need in future: .inf="null"	×
93	post_to_factbase(body, token)	×
94
95	original_data	×
96	}
97
98	#' @importFrom httr POST timeout add_headers content
99	post_to_factbase <- function(body, token) {
100	message(paste0("POSTing ", nchar(body), " characters from ", Sys.info()["nodename"]))	×
101	url <- "https://factbase.azurewebsites.net/fact"	×
102	r <- POST(url, body = body, encode = "json",	×
103	add_headers(`x-facttoken` = token), timeout(3600))	×
104	if (r$status_code != 200)	×
105	stop(paste0(r$status_code, ": ", content(r, "text")))	×
106	}
107
108	#' Upload a relationship to Factbase.
109	#'
110	#' @param data A data.frame with at least two columns, each of which should be coerced to character
111	#' vectors. The first column is the dimension we are mapping from. Subsequent columns contain
112	#' labels in dimensions that we are mapping to. The names of these columns to be used as the
113	#' names of these dimensions.
114	#' @param token A guid that identifies and authenticates the request. Talk to Oliver if you need
115	#' one of these.
116	#' @param mode One of "replace_all", "append" or "append_or_update" See comments for
117	#' FactPostUpdateType.
118	#'
119	#' @return The value of `data` that was passed in, so caller can see data uploaded if this is the
120	#' last call in R code
121	#'
122	#' @importFrom RJSONIO toJSON
123	#' @export
124	UploadRelationshipToFactbase <- function(data, token, mode="replace_all") {
125	if (!is.data.frame(data))	×
126	# Include the data in the error message because often this will be an SQL error,
127	# returned instead of a data.frame. This makes it easier for users to spot the problem.
128	stop(paste("'data' must be a data.frame, but got", format(data)))	×
129	if (length(data) < 2)	×
130	stop("There must be at least two columns in 'data'")	×
131	original_data <- data	×
132
133	# Build dimensions.
134	dimensions <- mapply(function(v, name, i) {	×
135	list(	×
136	name=name,	×
137	dimensionType="in_data",	×
138	valueType="text")	×
139	}, data, names(data), SIMPLIFY=FALSE, USE.NAMES=FALSE)	×
140	dimensions[[1]]$unique <- TRUE	×
141
142	# Coerce all to character vectors.
143	data <- lapply(data, function(column) { as.character(column) })	×
144
145	# Structure observations as a list of lists for toJSON.
146	list_for_observation <- function(...) {	×
147	list(...)	×
148	}
149	mapply_args <- c(list_for_observation, unname(data), list(SIMPLIFY=FALSE, USE.NAMES=FALSE))	×
150	observations <- do.call("mapply", mapply_args)	×
151
152	# Make HTTP request
153	body <- toJSON(list(	×
154	relationship=list(	×
155	type="many_to_one"	×
156	),
157	update=mode,	×
158	dimensions=dimensions,	×
159	data=observations	×
160	), digits=15, .na="null")	×
161	message(paste("Dimensions:", paste(vapply(dimensions, function(d) {d$name}, ""),	×
162	collapse=", ")))	×
163	post_to_factbase(body, token)	×
164
165	original_data # so caller can see data uploaded if this is the last call in R code	×
166	}

Displayr / flipAPI / 877

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous