55# ' @param dataset_list A list of two or more crunch datasets. Datasets should be
66# ' provided in time order. From oldest to youngest. (i.e, wave 1, wave 2,
77# ' ..., wave n)
8- # ' @param vars A character vector of question aliases to be included in the report
8+ # ' @param vars A character vector of question aliases to be included in the
9+ # ' report this may include aliases that are available in at least one of the
10+ # ' datasets specified in dataset_list
911# ' @param weight NULL to accept each dataset's current weight or a single alias
10- # ' that is available in all datasets as a string.
12+ # ' that is available in all datasets as a string. Multiple weights is not
13+ # ' recommended in a tracking report.
1114# ' @param labels The labels for each wave. Should be of a length that
1215# ' matches the number of datasets.
1316tracking_report <- function (dataset_list , vars , labels = NULL , weight = NULL ) {
14- # topline tabbooks
1517 tabs <- tracking_report_tabs(dataset_list , vars , weight )
1618
1719 if (is.null(labels ))
1820 labels <- paste0(" Wave " dataset_list )))
1921
20- # Use the first result item as a skeleton
21- rebuilt_results <- tabs [[1 ]]
22+ # In previous iterations we used the first item of tabs as a skeleton
23+ # However, what if there is an alias that is not included in the first
24+ # variable? Instead we build the rebuilt_results object piece by piece
25+ # using the first available result for each alias to create a skeleton
26+
27+ rebuilt_results <- list ()
28+ class(rebuilt_results ) <- c(" Toplines" " CrunchTabs"
29+ rebuilt_results $ results <- lapply(vars , function (x ) NULL )
30+ rebuilt_results $ metadata <- tabs [[1 ]]$ metadata
31+ names(rebuilt_results $ results ) <- vars
32+ rebuilt_results $ banner <- NULL
33+
34+ # Loop through each element of tabs, suck out the first result available
35+ # per alias and use that result as part of the skeleton. If there is more
36+ # than one result but less than n results, we need to denote that for future
37+ # use.
38+ #
39+ # For example, if someone has a survey where "q1" was asked in waves 1 and 3
40+ # but not 2 - we need a good way to identify this.
41+
42+ for (v in vars ) {
43+ var_results <- lapply(tabs , function (x ) return (x $ results [[v ]]))
44+ results_available <- which(! unlist(lapply(var_results , is.null )))
45+ first_var_result <- which(! unlist(lapply(var_results , is.null )))[1 ]
46+ rebuilt_results $ results [[v ]] <- var_results [[first_var_result ]]
47+ rebuilt_results $ results [[v ]]$ available_at <- results_available
48+
49+
50+ # For each alias, we set an attribute that identifies it's availability
51+ # across all the datasets: "all", "partial", and "single"
52+ # - "all" means it is available in every dataset
53+ # - "partial" means it is available in only some datasets
54+ # - "single" means it is available in exactly one dataset
55+
56+ # Because we use subsetting at the list level, "all" and "partial"
57+ # would follow a typical path that labeling was adjusted appropriately
58+ # for presentation in the resulting pdf "single" should act as a simple
59+ # passthrough where no additional formatting or manipulation takes place
60+ # on the result.
61+
62+ # The single case
63+ if (length(results_available ) == 1 ) {
64+ rebuilt_results $ results [[v ]]$ availability <- " single"
65+ } else {
66+ rebuilt_results $ results [[v ]]$ availability <- " general"
67+ }
68+
69+ }
70+
71+ # Now that we have an attribute that identifies availability we can use it as
72+ # a trigger for logic that allows us to customize the result of each
73+ # condition.
74+ #
75+ # We wil loop over each variable and either combine those elements that are
76+ # setup for tracking, or passthrough those that are singles. As singles
77+ # represent the simplest case, we will deal with them first.
2278
2379 for (v in vars ) {
24- message(" Preparing: " v )
80+ if (rebuilt_results $ results [[v ]]$ availability == " single"
81+ next
82+ }
83+
84+ available_at <- rebuilt_results $ results [[v ]]$ available_at
85+
86+ message(" Preparing: " v ) # TODO: Delete me after feature dev
2587 result_list <- lapply(tabs , function (x ) x $ results [[v ]])
2688 if (rebuilt_results $ results [[v ]]$ type == " categorical_array"
2789 rebuilt_results $ results <- c(
2890 catArrayToCategoricals(
29- result_list ,
91+ result_list [ available_at ] ,
3092 question_alias = v ,
31- labels = labels
93+ labels = labels [ available_at ]
3294 ),
3395 rebuilt_results $ results
3496 )
3597 rebuilt_results $ results [[v ]] <- NULL
3698
37- # Fix the class!
99+ # We must fake the class of the object
38100 class(rebuilt_results $ results ) <- c(" ToplineResults" " CrosstabsResults"
39101 } else {
40102 rebuilt_results $ results [[v ]] <- as.ToplineCategoricalArray(
41- result_list ,
103+ result_list [ available_at ] ,
42104 question_alias = v ,
43- labels = labels
44- )
105+ labels = labels [ available_at ]
106+ )
45107 }
46108
47109 }
@@ -59,7 +121,8 @@ tracking_report_tabs <- function(datasets, vars, weight = NULL) {
59121 if (is.null(weight )) {
60122 weight = weight(x )
61123 }
62- crosstabs(x , vars , weight , include_numeric = TRUE )
124+ adj_vars = vars [vars %in% names(x )]
125+ crosstabs(x , adj_vars , weight , include_numeric = TRUE )
63126 }
64127 )
65128}
0 commit comments