Nothing
R/proc_freq.R
In procs: Recreates Some 'SAS®' Procedures in 'R'
Defines functions
gen_output_freq
gen_report_freq
get_output_tables
get_table_list
get_nway_zero_fills
get_nlevels
get_output_specs
get_output_twoway
get_output_oneway
cross_tab
freq_twoway
freq_oneway
log_freq
proc_freq
Documented in
proc_freq
# Proc Freq ---------------------------------------------------------------
#' @title Generates Frequency Statistics
#' @encoding UTF-8
#' @description The \code{proc_freq} function generates frequency statistics.
#' It is both an interactive function that can be used for data exploration,
#' and can produce dataset output for further analysis.
#' The function can perform one and two-way frequencies. Two-way
#' frequencies are produced as a cross-tabulation by default. There
#' are many options to control the generated tables. The function will return
#' requested tables in a named list.
#' @details
#' The \code{proc_freq} function generates frequency statistics
#' for one-way and two-way tables. Data is passed in on the \code{data}
#' parameter. The desired frequencies are specified on the \code{tables}
#' parameter.
#'
#' @section Report Output:
#' By default, \code{proc_freq} results will
#' be immediately sent to the viewer as an HTML report. This functionality
#' makes it easy to get a quick analysis of your data with very little
#' effort. To turn off the interactive report, pass the "noprint" keyword
#' to the \code{options} parameter or set \code{options("procs.print" = FALSE)}.
#'
#' The \code{titles} parameter allows you to set one or more titles for your
#' report. Pass these titles as a vector of strings.
#'
#' If the frequency variables have a label assigned, that label
#' will be used in the report output. This feature gives you some control
#' over the column headers in the final report.
#'
#' The exact datasets used for the interactive output can be returned as a list.
#' To return these datasets as a list, pass
#' the "report" keyword on the \code{output} parameter. This list may in
#' turn be passed to \code{\link{proc_print}} to write the report to a file.
#'
#' @section Data Frame Output:
#' The \code{proc_freq} function returns output datasets.
#' If you are requesting only one table, a single
#' data frame will be returned. If you request multiple tables, a list of data
#' frames will be returned.
#'
#' By default, the list items are named according to the
#' strings specified on the \code{tables} parameter. You may control
#' the names of the returned results by using a named vector on the
#' \code{tables} parameter.
#'
#' The standard output datasets are optimized for data manipulation.
#' Column names have been standardized, and additional variables may
#' be present to help with data manipulation. For instance, the by variable will
#' always be named "BY", and the frequency category will always be named "CAT".
#' In addition, data values in the
#' output datasets are not rounded or formatted
#' to give you the most accurate statistical results.
#'
#' @section Frequency Weight:
#' Normally the \code{proc_freq} function counts each row in the
#' input data equally. In some cases, however, each row in the data
#' can represent multiple observations, and rows should not be treated
#' equally. In these cases, use the \code{weight} parameter. The parameter
#' accepts a variable/column name to use as the weighted value. If the
#' \code{weight} parameter is used, the function will sum the weighted values
#' instead of counting rows.
#'
#' @section By Groups:
#' You may request that frequencies be separated into by groups using the
#' \code{by} parameter. The parameter accepts one or more variable names
#' from the input dataset. When this parameter is assigned, the data
#' will be subset by the "by" variable(s) before frequency counts are
#' calculated. On the interactive report, the by groups will appear in
#' separate tables. On the output dataset, the by groups will be identified
#' by additional columns.
#'
#' @section Options:
#' The \code{options} parameter accepts a vector of options. Normally, these
#' options must be quoted. But you may pass them unquoted using the \code{v()}
#' function. For example, you can request the number of category levels
#' and the Chi-Square statistic like this: \code{options = v(nlevels, chisq)}.
#'
#' Below are all the available options and a description of each:
#' \itemize{
#' \item{\strong{crosstab}: Two-way output tables are a list style by default.
#' If you want a crosstab style, pass the "crosstab" option.
#' }
#' \item{\strong{list}: Two-way interactive tables are a crosstab style
#' by default. If you want a list style two-way table, pass the "list" option.
#' }
#' \item{\strong{missing}: Normally, missing values are not counted and not
#' shown on frequency tables. The "missing" option allows you to treat
#' missing (NA) values as normal values, so that they are counted and
#' shown on the frequency table. Missing levels will appear on the
#' table as a single dot (".").
#' }
#' \item{\strong{nlevels}: The "nlevels" option will display the number of unique
#' values for each variable in the frequency table. These levels are generated
#' as a separate table that appears on the report, and will also be output from
#' the function as a separate dataset.
#' }
#' \item{\strong{nocol}: Two-way cross tabulation tables include column percents
#' by default. To turn them off, pass the "nocol" option.
#' }
#' \item{\strong{nocum}: Whether to include the cumulative frequency and percent
#' columns on one-way, interactive tables. These columns are included by default.
#' To turn them off, pass the "nocum" option.
#' }
#' \item{\strong{nofreq}: The "nofreq" option will remove the frequency column
#' from one-way and two-way tables.
#' }
#' \item{\strong{nopercent}: The "nopercent" option will remove the percent column
#' from one-way and two-way tables.
#' }
#' \item{\strong{noprint}: Whether to print the interactive report to the
#' viewer. By default, the report is printed to the viewer. The "noprint"
#' option will inhibit printing.
#' }
#' \item{\strong{nonobs}: Whether to include the number of observations "N"
#' column on the output and interactive tables. By default, the N column
#' will be included. The "nonobs" option turns it off.
#' }
#' \item{\strong{norow}: Whether to include the row percentages on two-way
#' crosstab tables. The "norow" option will turn them off.
#' }
#' \item{\strong{nosparse/sparse}: Whether to include categories for which there are no
#' frequency counts. Zero-count categories will be included by default, which
#' is the "sparse" option. If the
#' "nosparse" option is present, zero-count categories will be removed.
#' }
#' \item{\strong{notable}: Whether to include the frequency table in the output
#' dataset list. Normally, the frequency table is included. You may want to
#' exclude the frequency table in some cases, for instance, if you only
#' want the Chi-Square statistic.
#' }
#' \item{\strong{outcum}: Whether to include the cumulative frequency and percent
#' on output frequency tables. By default, these columns are not included.
#' The "outcum" option will include them.
#' }
#' \item{\strong{outpct}: Whether to include row and column percentages on
#' two-way output datasets. When specified, two columns are added to the
#' output dataset: "PCT_ROW", which contains the row percentage for each
#' cell, and "PCT_COL", which contains the column percentage for each cell.
#' This option is only meaningful for two-way interactions; for one-way
#' frequency tables it is silently ignored.
#' }
#' \item{\strong{varnames}: Replaces the standardized "CAT" and "BY" output
#' column names with the original variable names from which those columns
#' are derived. The variable names are taken from the column labels.
#' This option only affects data frame output, not the interactive report.
#' }
#' }
#' @section Statistics Options:
#' In addition to the above options, the \code{options} parameter accepts
#' some statistics options. The following keywords will generate
#' an additional tables of specialized statistics. These statistics
#' options are only available on two-way tables:
#' \itemize{
#' \item{\strong{chisq}: Requests that the Chi-square statistics be produced.
#' }
#' \item{\strong{fisher}: Requests that the Fisher's exact statistics be produced.
#' }
#' }
#' @section Using Factors:
#' There are some occasions when you may want to define the \code{tables} variable
#' or \code{by} variables as a factor. One occasion is for sorting/ordering,
#' and the other is for obtaining zero-counts on sparse data.
#'
#' To order the frequency categories in the frequency output, define the
#' \code{tables} variable as a factor in the desired order. The function will
#' then retain that order for the frequency categories in the output dataset
#' and report.
#'
#' You may also wish to
#' define the tables variable as a factor if you are dealing with sparse data
#' and some of the frequency categories are not present in the data. To ensure
#' these categories are displayed with zero-counts, define the \code{tables} variable
#' or \code{by} variable
#' as a factor and use the "sparse" option. Note
#' that the "sparse" option is actually the default.
#'
#' If you do not want to
#' show the zero-count categories on a variable that is defined as a factor,
#' pass the "nosparse" keyword on the \code{options} parameter.
#'
#' @section Ordering Frequency Output:
#' Frequency output can be ordered using the \code{order} parameter. There are
#' several choices:
#' \itemize{
#' \item{\strong{internal}: The internal or "natural" order of the table variables.
#' For character variables, "internal" means alphabetical order. For factors,
#' "internal" means by order of the levels.}
#' \item{\strong{data}: "data" order is different from "internal" order. "data"
#' order means the order that the data appears in the incoming data frame, which
#' may or may not be the same as the "internal" order. This
#' choice essentially sorts the frequencies according to however the
#' table variable values were encountered in the incoming data.}
#' \item{\strong{freq}: The "freq" order value means to sort the output in
#' descending frequency order.}
#' \item{\strong{formatted}: If there is a format assigned to the table variable(s),
#' you may also use "formatted" order. "formatted" order means to apply the
#' format to the table variable(s) and then sort the frequencies according to the
#' order specified in the format. The format should be a user-defined
#' format as defined in the \strong{fmtr} package.}
#' }
#' Note that the \code{order} parameter applies to both the interactive report
#' and the data frame output. This behavior is different from SAS, which only
#' orders the interactive report. The behavior of the \code{order} parameter was
#' modified to reduce subsequent sorts and make it more convenient for the user.
#' @section Data Shaping:
#' By default, the \code{proc_freq} function returns an output dataset of
#' frequency results. If running interactively, the function also prints
#' the frequency results to the viewer. As described above, the output
#' dataset can be somewhat different than the dataset sent to the viewer.
#' The \code{output} parameter allows you to choose which datasets to return,
#' and how those datasets are structured.
#'
#' There are three choices of datasets:
#' "out", "report", and "none". The "out" keyword returns the default output
#' dataset. The "report" keyword returns the dataset(s) sent to the viewer. You
#' may also pass "none" if you don't want any datasets returned from the function.
#'
#' In addition, the output dataset produced by the "out" keyword can be shaped
#' in different ways. These shaping options allow you to decide whether the
#' data should be returned long and skinny, or short and wide. The shaping
#' options can reduce the amount of data manipulation necessary to get the
#' frequencies into the desired form. The
#' shaping options are as follows:
#' \itemize{
#' \item{\strong{long}: Transposes the output datasets
#' so that statistics are in rows and frequency categories are in columns.
#' }
#' \item{\strong{stacked}: Requests that output datasets
#' be returned in "stacked" form, such that both statistics and frequency
#' categories are in rows.
#' }
#' \item{\strong{wide}: Requests that output datasets
#' be returned in "wide" form, such that statistics are across the top in
#' columns, and frequency categories are in rows. This shaping option
#' is the default.
#' }
#' }
#' @section Plots:
#' The \code{proc_freq} function can generate plots. These plots
#' can be most easily generated by setting \code{plots = TRUE}. The default
#' plots are bar charts showing the frequency counts for each category
#' and each table request. For two-way interactions, the function will
#' plot a bar chart for each interaction.
#'
#' In addition to standard bar charts, the function can produce dot plots, stacked
#' bar charts, and clustered bar charts. To request these types of plots, pass
#' a \code{\link{freqplot}} function to the \code{plots} parameter. The
#' \code{\link{freqplot}} function provides several optional parameters for customizing
#' your chart. See the \code{\link{freqplot}} documentation for a full
#' list of options and more plot examples.
#' @param data The input data frame to perform frequency calculations on.
#' Input data as the first parameter makes this function pipe-friendly.
#' @param tables The variable or variables to perform frequency counts on.
#' The table specifications are passed as a vector of strings. For one-way
#' frequencies, simply pass the variable name.
#' For two-way tables, pass the desired combination of variables separated by a
#' star (*) operator. The parameter does not accept SAS® style grouping syntax.
#' All cross combinations should be listed explicitly. If the
#' table request is named, the name will be used as the list item name on the
#' return list of tables. See "Example 3" for an illustration on how to name an
#' output table.
#' @param output Whether or not to return datasets from the function. Valid
#' values are "out", "none", and "report". Default is "out". This parameter
#' also accepts the data shaping options "long", "stacked", and "wide". See
#' the \strong{Data Shaping} section for a description of these options. Multiple
#' output keywords may be passed on a character vector. For example,
#' to produce both a report dataset and a "long" output dataset,
#' use the parameter \code{output = c("report", "out", "long")}.
#' @param by An optional by group. Parameter accepts a vector of one or more
#' variable names. When this parameter is set, data
#' will be subset for each by group, and tables will be generated for
#' each subset.
#' @param weight An optional weight parameter. This parameter is passed
#' as a variable name to use for the weight. If a weight variable is
#' indicated, the weighted value will be summed to calculate the frequency
#' counts.
#' @param options The options desired for the function.
#' Options are passed to the parameter as a vector of quoted strings. You may
#' also use the \code{v()} function to pass unquoted strings.
#' The following options are available:
#' "chisq", "crosstab", "fisher", "list", "missing",
#' "nlevels", "nocol",
#' "nocum", "nofreq", "nopercent", "noprint",
#' "nonobs", "norow", "nosparse", "notable", "outcum", "outpct", "varnames". See
#' the \strong{Options} section for a description of these options.
#' @param titles A vector of titles to assign to the interactive report.
#' @param order Indicates how to order the function output. Options are "internal",
#' "formatted", "freq" and "data". Default is "internal". See the section
#' on "Ordering Frequency Output" for more information on this parameter.
#' @param plots Pass the desired plot(s) on this parameter. Valid values are TRUE,
#' NULL, or a call to the \code{\link{freqplot}} function. Default is NULL,
#' meaning no
#' plots are desired. The value TRUE will give a default frequency plot for each
#' table request. If there are multiple table requests, you can pass a single
#' plot request which will apply to all tables, or a list of plot requests that
#' align one-to-one for each table request.
#' @param where An expression to filter the rows before the frequencies are
#' calculated. Use the \code{\link[base]{expression}} function to define
#' the filter.
#' @return The function will return all requested datasets by default. This is
#' equivalent to the \code{output = "out"} option. To return the datasets
#' as created for the interactive report, pass the "report" output option. If
#' no output datasets are desired, pass the "none" output option. If a
#' single dataset is requested, the function
#' will return a single dataset. If multiple datasets are requested, the function
#' will return a list of datasets. The type of data frame returned will
#' correspond to the type of data frame passed in on the \code{data} parameter.
#' If the input data is a tibble, the output data will be a
#' tibble. If the input data is a Base R data frame, the output data will be
#' a Base R data frame.
#' @param rename A named vector of variables to rename on the frequency output
#' dataset(s), where the name is the existing variable name and the value is
#' the desired new name. If there are multiple tables, you may supply one
#' rename vector for all tables, or a list of vectors, one for each table.
#' If using a list of vectors, they may either be named or unnamed. If named,
#' names should match the table names. The rename vector will only apply to
#' the frequency output dataset(s), not the interactive report, report
#' datasets, nlevels, or any statistical output. The rename operation is
#' performed before the \code{keep} and \code{drop} operations, so the
#' \code{keep} and \code{drop} vectors should reference the new variable names.
#' @param keep A vector of variables to keep on the frequency output dataset(s). If there
#' are multiple tables, you may supply one keep vector for all tables, or
#' a list of vectors, one for each table. If using a list of vectors, they
#' may either be named or unnamed. If named, names should match the table names.
#' The keep vector will only apply to the frequency output dataset(s), not
#' the interactive report, report datasets, nlevels, or any statistical output.
#' @param drop A vector of variables to drop from the frequency output dataset(s). If there
#' are multiple tables, you may supply one drop vector for all tables, or
#' a list of vectors, one for each table. If using a list of vectors, they
#' may either be named or unnamed. If named, names should match the table names.
#' The drop vector will only apply to the frequency output dataset(s), not
#' the interactive report, report datasets, nlevels, or any statistical output.
#' If both \code{keep} and \code{drop} are supplied, \code{keep} is applied first.
#' @seealso For summary statistics, see \code{\link{proc_means}}. To pivot
#' or transpose the data coming from \code{proc_freq},
#' see \code{\link{proc_transpose}}. For frequency plots,
#' see \code{\link{freqplot}}.
#' @examples
#' library(procs)
#'
#' # Turn off printing for CRAN checks
#' options("procs.print" = FALSE)
#'
#' # Create sample data
#' df <- as.data.frame(HairEyeColor, stringsAsFactors = FALSE)
#'
#' # Assign labels
#' labels(df) <- list(Hair = "Hair Color",
#' Eye = "Eye Color",
#' Sex = "Sex at Birth")
#'
#' # Example #1: One way frequencies on Hair and Eye color with weight option.
#' res <- proc_freq(df,
#' tables = v(Hair, Eye),
#' options = outcum,
#' weight = Freq)
#'
#' # View result data
#' res
#' # $Hair
#' # VAR CAT N CNT PCT CUMSUM CUMPCT
#' # 1 Hair Black 592 108 18.24324 108 18.24324
#' # 2 Hair Blond 592 127 21.45270 235 39.69595
#' # 3 Hair Brown 592 286 48.31081 521 88.00676
#' # 4 Hair Red 592 71 11.99324 592 100.00000
#' #
#' # $Eye
#' # VAR CAT N CNT PCT CUMSUM CUMPCT
#' # 1 Eye Blue 592 215 36.31757 215 36.31757
#' # 2 Eye Brown 592 220 37.16216 435 73.47973
#' # 3 Eye Green 592 64 10.81081 499 84.29054
#' # 4 Eye Hazel 592 93 15.70946 592 100.00000
#'
#' # Example #2: 2 x 2 Crosstabulation table with Chi-Square statistic
#' res <- proc_freq(df, tables = Hair * Eye,
#' weight = Freq,
#' options = v(crosstab, chisq))
#'
#' # View result data
#' res
#' #$`Hair * Eye`
#' # Category Statistic Blue Brown Green Hazel Total
#' #1 Black Frequency 20.000000 68.000000 5.0000000 15.000000 108.00000
#' #2 Black Percent 3.378378 11.486486 0.8445946 2.533784 18.24324
#' #3 Black Row Pct 18.518519 62.962963 4.6296296 13.888889 NA
#' #4 Black Col Pct 9.302326 30.909091 7.8125000 16.129032 NA
#' #5 Blond Frequency 94.000000 7.000000 16.0000000 10.000000 127.00000
#' #6 Blond Percent 15.878378 1.182432 2.7027027 1.689189 21.45270
#' #7 Blond Row Pct 74.015748 5.511811 12.5984252 7.874016 NA
#' #8 Blond Col Pct 43.720930 3.181818 25.0000000 10.752688 NA
#' #9 Brown Frequency 84.000000 119.000000 29.0000000 54.000000 286.00000
#' #10 Brown Percent 14.189189 20.101351 4.8986486 9.121622 48.31081
#' #11 Brown Row Pct 29.370629 41.608392 10.1398601 18.881119 NA
#' #12 Brown Col Pct 39.069767 54.090909 45.3125000 58.064516 NA
#' #13 Red Frequency 17.000000 26.000000 14.0000000 14.000000 71.00000
#' #14 Red Percent 2.871622 4.391892 2.3648649 2.364865 11.99324
#' #15 Red Row Pct 23.943662 36.619718 19.7183099 19.718310 NA
#' #16 Red Col Pct 7.906977 11.818182 21.8750000 15.053763 NA
#' #17 Total Frequency 215.000000 220.000000 64.0000000 93.000000 592.00000
#' #18 Total Percent 36.317568 37.162162 10.8108108 15.709459 100.00000
#'
#' # $`chisq:Hair * Eye`
#' # STAT DF VAL PROB
#' # 1 Chi-Square 9 138.2898 2.325287e-25
#' # 2 Continuity Adj. Chi-Square 9 138.2898 2.325287e-25
#'
#' # Example #3: By variable with named table request
#' res <- proc_freq(df, tables = v(Hair, Eye, Cross = Hair * Eye),
#' by = Sex,
#' weight = Freq)
#'
#' # View result data
#' res
#' # $Hair
#' # BY VAR CAT N CNT PCT
#' # 1 Female Hair Black 313 52 16.61342
#' # 2 Female Hair Blond 313 81 25.87859
#' # 3 Female Hair Brown 313 143 45.68690
#' # 4 Female Hair Red 313 37 11.82109
#' # 5 Male Hair Black 279 56 20.07168
#' # 6 Male Hair Blond 279 46 16.48746
#' # 7 Male Hair Brown 279 143 51.25448
#' # 8 Male Hair Red 279 34 12.18638
#' #
#' # $Eye
#' # BY VAR CAT N CNT PCT
#' # 1 Female Eye Blue 313 114 36.421725
#' # 2 Female Eye Brown 313 122 38.977636
#' # 3 Female Eye Green 313 31 9.904153
#' # 4 Female Eye Hazel 313 46 14.696486
#' # 5 Male Eye Blue 279 101 36.200717
#' # 6 Male Eye Brown 279 98 35.125448
#' # 7 Male Eye Green 279 33 11.827957
#' # 8 Male Eye Hazel 279 47 16.845878
#' #
#' # $Cross
#' # BY VAR1 VAR2 CAT1 CAT2 N CNT PCT
#' # 1 Female Hair Eye Black Blue 313 9 2.8753994
#' # 2 Female Hair Eye Black Brown 313 36 11.5015974
#' # 3 Female Hair Eye Black Green 313 2 0.6389776
#' # 4 Female Hair Eye Black Hazel 313 5 1.5974441
#' # 5 Female Hair Eye Blond Blue 313 64 20.4472843
#' # 6 Female Hair Eye Blond Brown 313 4 1.2779553
#' # 7 Female Hair Eye Blond Green 313 8 2.5559105
#' # 8 Female Hair Eye Blond Hazel 313 5 1.5974441
#' # 9 Female Hair Eye Brown Blue 313 34 10.8626198
#' # 10 Female Hair Eye Brown Brown 313 66 21.0862620
#' # 11 Female Hair Eye Brown Green 313 14 4.4728435
#' # 12 Female Hair Eye Brown Hazel 313 29 9.2651757
#' # 13 Female Hair Eye Red Blue 313 7 2.2364217
#' # 14 Female Hair Eye Red Brown 313 16 5.1118211
#' # 15 Female Hair Eye Red Green 313 7 2.2364217
#' # 16 Female Hair Eye Red Hazel 313 7 2.2364217
#' # 17 Male Hair Eye Black Blue 279 11 3.9426523
#' # 18 Male Hair Eye Black Brown 279 32 11.4695341
#' # 19 Male Hair Eye Black Green 279 3 1.0752688
#' # 20 Male Hair Eye Black Hazel 279 10 3.5842294
#' # 21 Male Hair Eye Blond Blue 279 30 10.7526882
#' # 22 Male Hair Eye Blond Brown 279 3 1.0752688
#' # 23 Male Hair Eye Blond Green 279 8 2.8673835
#' # 24 Male Hair Eye Blond Hazel 279 5 1.7921147
#' # 25 Male Hair Eye Brown Blue 279 50 17.9211470
#' # 26 Male Hair Eye Brown Brown 279 53 18.9964158
#' # 27 Male Hair Eye Brown Green 279 15 5.3763441
#' # 28 Male Hair Eye Brown Hazel 279 25 8.9605735
#' # 29 Male Hair Eye Red Blue 279 10 3.5842294
#' # 30 Male Hair Eye Red Brown 279 10 3.5842294
#' # 31 Male Hair Eye Red Green 279 7 2.5089606
#' # 32 Male Hair Eye Red Hazel 279 7 2.5089606
#'
#' # Example #4: Default Plots
#' res <- proc_freq(df, tables = v(Hair, Eye, Cross = Hair * Eye),
#' weight = Freq,
#' plots = TRUE, # Request default plots
#' output = report # So we can see plot objects
#' )
#'
#' # View results
#' # Frequency plots are created for each table
#' res
#' # $Hair
#' # CAT N CNT PCT CUMSUM CUMPCT
#' # 1 Black 592 108 18.24324 108 18.24324
#' # 2 Blond 592 127 21.45270 235 39.69595
#' # 3 Brown 592 286 48.31081 521 88.00676
#' # 4 Red 592 71 11.99324 592 100.00000
#' #
#' # $`Plots: Hair`
#' # # A plot specification:
#' # - path: 'C:\Users\dbosa\AppData\Local\Temp\RtmpOYrg1Y\file5dfa8212f57c7.jpg'
#' # - height: 4.5
#' # - width: 6
#' #
#' # $Eye
#' # CAT N CNT PCT CUMSUM CUMPCT
#' # 1 Blue 592 215 36.31757 215 36.31757
#' # 2 Brown 592 220 37.16216 435 73.47973
#' # 3 Green 592 64 10.81081 499 84.29054
#' # 4 Hazel 592 93 15.70946 592 100.00000
#' #
#' # $`Plots: Eye`
#' # # A plot specification:
#' # - path: 'C:\Users\dbosa\AppData\Local\Temp\RtmpOYrg1Y\file5dfa854b429fc.jpg'
#' # - height: 4.5
#' # - width: 6
#' #
#' # $Cross
#' # CAT Statistic Blue Brown Green Hazel Total
#' # 1 Black Frequency 20.000000 68.000000 5.0000000 15.000000 108.00000
#' # 2 Black Percent 3.378378 11.486486 0.8445946 2.533784 18.24324
#' # 3 Black Row Pct 18.518519 62.962963 4.6296296 13.888889 NA
#' # 4 Black Col Pct 9.302326 30.909091 7.8125000 16.129032 NA
#' # 5 Blond Frequency 94.000000 7.000000 16.0000000 10.000000 127.00000
#' # 6 Blond Percent 15.878378 1.182432 2.7027027 1.689189 21.45270
#' # 7 Blond Row Pct 74.015748 5.511811 12.5984252 7.874016 NA
#' # 8 Blond Col Pct 43.720930 3.181818 25.0000000 10.752688 NA
#' # 9 Brown Frequency 84.000000 119.000000 29.0000000 54.000000 286.00000
#' # 10 Brown Percent 14.189189 20.101351 4.8986486 9.121622 48.31081
#' # 11 Brown Row Pct 29.370629 41.608392 10.1398601 18.881119 NA
#' # 12 Brown Col Pct 39.069767 54.090909 45.3125000 58.064516 NA
#' # 13 Red Frequency 17.000000 26.000000 14.0000000 14.000000 71.00000
#' # 14 Red Percent 2.871622 4.391892 2.3648649 2.364865 11.99324
#' # 15 Red Row Pct 23.943662 36.619718 19.7183099 19.718310 NA
#' # 16 Red Col Pct 7.906977 11.818182 21.8750000 15.053763 NA
#' # 17 Total Frequency 215.000000 220.000000 64.0000000 93.000000 592.00000
#' # 18 Total Percent 36.317568 37.162162 10.8108108 15.709459 100.00000
#' #
#' # $`Plots: Hair * Eye`
#' # # A plot specification:
#' # - path: 'C:\Users\dbosa\AppData\Local\Temp\RtmpOYrg1Y\file5dfa87b6a3303.jpg'
#' # - height: 4.5
#' # - width: 6
#'
#' @import fmtr
#' @import tibble
#' @import common
#' @export
proc_freq <- function(data,
tables = NULL,
output = NULL,
by = NULL,
weight = NULL,
options = NULL,
titles = NULL,
order = "internal",
plots = NULL,
where = NULL,
rename = NULL,
keep = NULL,
drop = NULL
) {
# Allow single-value NSE on some parameters
by <- resolve_arg(by)
tables <- resolve_arg(tables)
weight <- resolve_arg(weight)
options <- resolve_arg(options)
output <- resolve_arg(output)
order <- resolve_arg(order)
# Parameter checks
if (!"data.frame" %in% class(data)) {
stop("Input data is not a data frame.")
}
if (nrow(data) == 0) {
stop("Input data has no rows.")
}
nms <- names(data)
if (!is.null(by)) {
if (!all(by %in% nms)) {
stop(paste("Invalid by name: ", by[!by %in% nms], "\n"))
}
}
if (!is.null(weight)) {
if (!all(weight %in% nms)) {
stop(paste("Invalid weight name: ", weight[!weight %in% nms], "\n"))
}
}
if (!is.null(tables)) {
locs <- grepl("*", tables, fixed = TRUE)
slocs <- unlist(strsplit(tables[locs], "*", fixed = TRUE))
vars <- c(tables[!locs], trimws(slocs))
vars <- unique(vars)
if (!all(vars %in% nms)) {
stop(paste("Invalid tables name: ", vars[!vars %in% nms], "\n"))
}
}
if (!is.null(output)) {
outs <- c("out", "report", "none", "wide", "long", "stacked")
if (!all(tolower(output) %in% outs)) {
stop(paste("Invalid output keyword: ", output[!tolower(output) %in% outs], "\n"))
}
}
if (!is.null(options)) {
kopts <- c("noprint",
"list", "nocol", "nocum", "nofreq", "nopercent",
"norow", "nosparse", "outcum",
"sparse", "crosstab",
"notable", "nonobs", "missing", "nlevels",
"outpct", # Output percentage options
"chisq", "fisher", # Statistics options
"alpha", # Setting options
"varnames" # Column naming options
)
# Future options
# "expected", "outexpect", "missprint", "cl", "maxlevels"
if (!all(tolower(options) %in% kopts)) {
stop(paste("Invalid options keyword: ", options[!tolower(options) %in% kopts], "\n"))
}
}
# Default order parameter
if (is.null(order)) {
order <- "internal"
} else {
order <- tolower(order)
if (!order %in% c("data", "internal", "formatted", "freq")) {
stop(paste0("Invalid value for 'order' parameter: '", order, "'\n",
"Valid values are: 'internal', 'freq', 'formatted', and 'data'"))
}
}
# Prepare plots for easier processing
if (!is.null(plots)) {
if ("logical" %in% class(plots)) {
plots <- "freqplot"
}
if (all(class(plots) == "list")) {
# Do nothing
} else if ("freqplot" %in% class(plots) |
"character" %in% class(plots)) {
tplots <- list()
for (idx in seq_along(tables)) {
tplots[[idx]] <- plots
}
plots <- tplots
}
}
# Set default statistics for output parameters
if (has_output(output))
outreq <- get_output_specs(tables, list(), options, output)
else
outreq <- NULL
# Deal with where expression
if (!is.null(where)) {
data <- subset_data(data, where)
}
rptflg <- FALSE
rptnm <- ""
if (has_report(output)) {
rptflg <- TRUE
}
if (has_view(options))
view <- TRUE
else
view <- FALSE
rptres <- NULL
res <- NULL
if (view | rptflg) {
rptres <- gen_report_freq(data = data,
by = by,
tables = tables,
options = options,
weight = weight,
view = view,
titles = titles,
order = order,
plots = plots)
}
if (length(outreq) > 0) {
res <- gen_output_freq(data = data,
by = by,
tables = tables,
options = options,
weight = weight,
output = outreq,
order = order,
rename = rename,
keep = keep,
drop = drop)
}
# Add report list if requested
if (rptflg & !is.null(rptres)) {
if (is.null(res))
res <- rptres
else {
res <- list(out = res, report = rptres)
}
}
log_freq(data = data, by = by, tables = tables, options = options, output = output,
weight = weight, view = view, titles = titles, order = order, where = where,
plots = plots, outcnt = length(res))
# If only one dataset returned, remove list
if (length(res) == 1) {
res <- res[[1]]
}
if (log_output()) {
log_logr(res)
return(res)
}
return(res)
}
log_freq <- function(data,
by = NULL,
tables = NULL,
output = NULL,
options = NULL,
weight = NULL,
view = TRUE,
titles = NULL,
order = NULL,
where = NULL,
plots = NULL,
outcnt = NULL) {
ret <- c()
indt <- " "
ret <- paste0("proc_freq: input data set ", nrow(data),
" rows and ", ncol(data), " columns")
if (!is.null(tables))
ret[length(ret) + 1] <- paste0(indt, "tables: ",
paste(tables, collapse = " "))
if (!is.null(by))
ret[length(ret) + 1] <- paste0(indt, "by: ", paste(by, collapse = " "))
if (!is.null(output))
ret[length(ret) + 1] <- paste0(indt, "output: ", paste(output, collapse = " "))
if (!is.null(weight))
ret[length(ret) + 1] <- paste0(indt, "weight: ", paste(weight, collapse = " "))
if (!is.null(view))
ret[length(ret) + 1]<- paste0(indt, "view: ", paste(view, collapse = ""))
if (!is.null(titles))
ret[length(ret) + 1] <- paste0(indt, "titles: ", paste(titles, collapse = "\n"))
if (!is.null(order))
ret[length(ret) + 1] <- paste0(indt, "order: ", paste(order, collapse = " "))
if (!is.null(where))
ret[length(ret) + 1] <- paste0(indt, "where: ", as.character(where))
if (!is.null(plots)) {
if ("logical" %in% class(plots)) {
ret[length(ret) + 1] <- paste0(indt, "plots: ", as.character(plots))
} else {
ret[length(ret) + 1] <- paste0(indt, "plots: ", "(object)")
}
}
if (!is.null(outcnt))
ret[length(ret) + 1] <- paste0(indt, "output: ", outcnt, " datasets")
plts <- freqplot(type = "dotplot")
log_logr(ret)
}
# Sub Procedures ----------------------------------------------------------
#' @import fmtr
#' @import stats
#' @import reporter
#' @import common
#' @noRd
freq_oneway <- function(data, tb, weight, options, out = FALSE, stats = NULL,
order = "") {
if (is.null(stats))
stats <- c("n", "cnt", "pct", "cumsum", "cumpct")
# Get target variable vector
var <- data[[tb]]
if (has_option(options, "missing")) {
if (is.factor(var)) {
nmiss <- sum(is.na(var))
if (nmiss > 0) {
var <- as.character(var)
var <- ifelse(is.na(var), ".", var)
}
} else {
var <- ifelse(is.na(var), ".", var)
}
}
# Get frequency counts
if (is.null(weight)) {
categories <- names(sort(table(var)))
frequencies <- as.vector(sort(table(var)))
} else {
if (nrow(data) == 0) {
cnts <- 0
categories <- ""
frequencies <- 0
} else {
cnts <- aggregate(data[[weight]], list(var), FUN = sum)
if (nrow(cnts) == 0) {
categories <- ""
frequencies <- 0
} else {
categories <- cnts$Group.1
frequencies <- cnts$x
}
}
}
# Perform calculations
n <- sum(frequencies, na.rm = TRUE)
percentages <- frequencies / n * 100
# Create result data frame
result <- data.frame("CAT" = categories,
"N" = n,
"CNT" = frequencies,
"PCT" = percentages,
stringsAsFactors = FALSE)
# Frequency order
if (order == "freq") {
result <- sort(result, by = "CNT", ascending = FALSE)
rownames(result) <- NULL
}
# Apply cumulative sums and percents
result$CUMSUM <- cumsum(result$CNT)
result$CUMPCT <- cumsum(result$PCT)
# Get any existing label for target variable
lbl <- attr(data[[tb]], "label")
if (is.null(lbl))
lbl <- tb
# Clear out any names
names(tb) <- NULL
# Apply default labels
labels(result) <- c(CAT= tb,
CNT = "Frequency",
PCT = "Percent",
CUMSUM = "Cumulative Frequency",
CUMPCT = "Cumulative Percent")
# Apply default formats
formats(result) <- list(CUMPCT = "%.2f",
PCT = "%.2f")
# browser()
if (option_true(options, "nonobs", FALSE) |
!"n" %in% stats) {
result[["N"]] <- NULL
}
# Kill freq if requested
if (option_true(options, "nofreq", FALSE) |
!"cnt" %in% stats) {
result[["CNT"]] <- NULL
}
# Kill pct if requested
if (option_true(options, "nopercent", FALSE) |
!"pct" %in% stats) {
result[["PCT"]] <- NULL
}
# Kill cum freq if requested
if ((out == FALSE & option_true(options, "nocum", FALSE)) |
(out == TRUE & !option_true(options, "outcum", FALSE))) {
result[["CUMSUM"]] <- NULL
}
# Kill cum pct if requested
if ((out == FALSE & option_true(options, "nocum", FALSE)) |
(out == TRUE & !option_true(options, "outcum", FALSE))) {
result[["CUMPCT"]] <- NULL
}
if (!is.null(stats)) {
# mp <- c(n = "N", cnt = "Frequency", pct = "Percent",
# cumsum = "Cum_Freq", cumpct = "Cum_Pct")
fstats <- stats[toupper(stats) %in% names(result)]
result <- result[ , c("CAT", toupper(fstats))]
}
# Add spanning headers
spn <- span(1, ncol(result), label = paste("Table of", lbl), level = 1)
attr(result, "spans") <- list(spn)
# Add footnote for missing values
if (!has_option(options, "missing")) {
nas <- is.na(data[[tb]])
if (!is.null(weight)) {
nacnts <- sum(data[[weight]][nas])
} else {
nacnts <- sum(nas)
}
if (nacnts > 0) {
ftns <- ftn("Frequency Missing = " %p% nacnts, align = "center",
blank_row = "none", borders = "all")
attr(result, "footnotes") <- list(ftns)
}
}
return(result)
}
#' @import fmtr
#' @import stats
#' @import common
#' @noRd
freq_twoway <- function(data, tb1, tb2, weight, options,
out = FALSE, stats = NULL, order = "") {
if (is.null(stats))
stats <- c("n", "cnt", "pct", "cumsum", "cumpct")
# Assign 1 to count column
if (is.null(weight) | weight != "__cnt")
data[["__cnt"]] <- 1
l1 <- NULL
l2 <- NULL
# Get target variables into vectors
if (is.factor(data[[tb1]])) {
l1 <- levels(data[[tb1]])
v1 <- as.character(data[[tb1]])
} else {
v1 <- data[[tb1]]
}
if (is.factor(data[[tb2]])) {
l2 <- levels(data[[tb2]])
v2 <- as.character(data[[tb2]])
} else {
v2 <- data[[tb2]]
}
# Deal with missing
if (has_option(options, "missing")) {
if (is.factor(v1)) {
nmiss <- sum(is.na(v1))
if (nmiss > 0) {
v1 <- as.character(v1)
v1 <- ifelse(is.na(v1), ".", v1)
}
} else {
v1 <- ifelse(is.na(v1), ".", v1)
}
if (is.factor(v2)) {
nmiss <- sum(is.na(v2))
if (nmiss > 0) {
v2 <- as.character(v2)
v2 <- ifelse(is.na(v2), ".", v2)
}
} else {
v2 <- ifelse(is.na(v2), ".", v2)
}
}
# Get unique values of variables
t1 <- names(sort(table(v1)))
t2 <- names(sort(table(v2)))
# Get unique combinations of variable values for zero-fill
ex <- expand.grid(tb1 = t1, tb2 = t2, stringsAsFactors = FALSE)
# Assign zero fill value
ex[["__cnt"]] <- 0
# Use weight variable if requested
if (is.null(weight)) {
c1 <- data[["__cnt"]]
} else {
c1 <-data[[weight]]
}
# Append zero fills
if (!option_true(options, "nosparse", FALSE)) {
c1 <- append(c1, ex[["__cnt"]])
v1 <- append(v1, ex[["tb1"]])
v2 <- append(v2, ex[["tb2"]])
}
# Get frequencies
cnts <- aggregate(c1, list(v1, v2), FUN = sum)
categories1 <- cnts$Group.1
categories2 <- cnts$Group.2
frequencies <- cnts$x
# Perform calculations
n <- sum(frequencies, na.rm = TRUE)
percentages <- frequencies / n * 100
# Create result data frame
result <- data.frame("CAT1" = categories1,
"CAT2" = categories2,
"N" = n,
"CNT" = frequencies,
"PCT" = percentages,
stringsAsFactors = FALSE)
# Deal with frequency sort
if (order == "freq") {
cnt1 <- aggregate(result[["CNT"]], list(result[["CAT1"]]), FUN = sum)
cnt2 <- aggregate(result[["CNT"]], list(result[["CAT2"]]), FUN = sum)
l1 <- sort(cnt1, by = "x", ascending = FALSE)[["Group.1"]]
l2 <- sort(cnt2, by = "x", ascending = FALSE)[["Group.1"]]
}
# Restore factors if necessary
if (!is.null(l1)) {
result$CAT1 <- factor(result$CAT1, levels = l1)
}
if (!is.null(l2)) {
result$CAT2 <- factor(result$CAT2, levels = l2)
}
# Sort result data frame
result <- sort(result, by = c("CAT1", "CAT2"))
# Kill rownames
rownames(result) <- NULL
result$CUMSUM = cumsum(result$CNT)
result$CUMPCT = cumsum(result$PCT)
# Compute row/column percentages for outpct option (two-way output only)
pct_row_col <- NULL
if (out && has_option(options, "outpct")) {
cat1totals <- aggregate(result$CNT, list(as.character(result$CAT1)), FUN = sum)
cat2totals <- aggregate(result$CNT, list(as.character(result$CAT2)), FUN = sum)
lkp_row <- cat1totals$x
names(lkp_row) <- cat1totals$Group.1
lkp_col <- cat2totals$x
names(lkp_col) <- cat2totals$Group.1
pct_row_col <- data.frame(
PCT_ROW = result$CNT / lkp_row[as.character(result$CAT1)] * 100,
PCT_COL = result$CNT / lkp_col[as.character(result$CAT2)] * 100,
stringsAsFactors = FALSE
)
rownames(pct_row_col) <- NULL
}
# Get labels on target variables if they exist
lbl1 <- attr(data[[tb1]], "label")
lbl2 <- attr(data[[tb2]], "label")
if (is.null(lbl1))
lbl1 <- tb1
if (is.null(lbl2))
lbl2 <- tb2
# Assign labels
labels(result) <- c(CAT1 = lbl1,
CAT2 = lbl2,
CNT = "Frequency",
PCT = "Percent",
CUMSUM = "Cumulative Frequency",
CUMPCT = "Cumulative Percent")
# Assign default formats
formats(result) <- list(PCT = paste0("%.4f"),
CUMPCT = paste0("%.4f"))
if (out == FALSE |
option_true(options, "nonobs", FALSE) | !"n" %in% stats) {
result[["N"]] <- NULL
}
# Kill freq if requested
if (option_true(options, "nofreq", FALSE) |
!"cnt" %in% stats) {
result[["CNT"]] <- NULL
}
# Kill pct if requested
if (option_true(options, "nopercent", FALSE) |
!"pct" %in% stats) {
result[["PCT"]] <- NULL
}
# Kill cum freq if requested
if (out == FALSE & option_true(options, "nocum"))
result[["CUMSUM"]] <- NULL
else if (out & !option_true(options, "outcum", FALSE)) {
result[["CUMSUM"]] <- NULL
}
# Kill cum pct if requested
if (out == FALSE & option_true(options, "nocum"))
result[["CUMPCT"]] <- NULL
else if (out & !option_true(options, "outcum", FALSE)) {
result[["CUMPCT"]] <- NULL
}
if (!is.null(stats)) {
# mp <- c(n = "N", cnt = "Frequency", pct = "Percent",
# cumsum = "Cum_Freq", cumpct = "Cum_Pct")
fstats <- stats[toupper(stats) %in% names(result)]
result <- result[ , c("CAT1", "CAT2", toupper(fstats))]
}
# Append PCT_ROW and PCT_COL if outpct was requested
if (!is.null(pct_row_col)) {
rownames(result) <- NULL
result <- cbind(result, pct_row_col)
labels(result) <- c(PCT_ROW = "Row Percent", PCT_COL = "Column Percent")
formats(result) <- list(PCT_ROW = "%.4f", PCT_COL = "%.4f")
}
# Add footnote for missing values
if (!has_option(options, "missing")) {
nas1 <- is.na(data[[tb1]])
nas2 <- is.na(data[[tb2]])
if (!is.null(weight)) {
na1cnts <- sum(data[[weight]][nas1])
na2cnts <- sum(data[[weight]][nas2])
} else {
na1cnts <- sum(nas1)
na2cnts <- sum(nas2)
}
if ((na1cnts + na2cnts) > 0) {
ftns <- ftn("Frequency Missing = " %p% (na1cnts + na2cnts),
align = "center",
blank_row = "none", borders = "all")
attr(result, "footnotes") <- list(ftns)
}
}
return(result)
}
#' @import fmtr
#' @import stats
#' @import common
#' @noRd
cross_tab <- function(freqdata, options, var1, var2, bylbl = NULL) {
lbl1 <- attr(freqdata$CAT1, "label")
lbl2 <- attr(freqdata$CAT2, "label")
#browser()
if (has_option(options, "missing")) {
v1 <- freqdata$CAT1
v2 <- freqdata$CAT2
if (is.factor(v1)) {
nmiss <- sum(is.na(v1))
if (nmiss > 0) {
v1 <- as.character(v1)
v1 <- ifelse(is.na(v1), ".", v1)
}
} else {
v1 <- ifelse(is.na(v1), ".", v1)
}
if (is.factor(v2)) {
nmiss <- sum(is.na(v2))
if (nmiss > 0) {
v2 <- as.character(v2)
v2 <- ifelse(is.na(v2), ".", v2)
}
} else {
v2 <- ifelse(is.na(v2), ".", v2)
}
freqdata$CAT1 <- v1
freqdata$CAT2 <- v2
}
nms <- names(freqdata)
if ("CUMSUM" %in% nms) {
freqdata$CUMSUM <- NULL
}
if ("CUMPCT" %in% nms) {
freqdata$CUMPCT <- NULL
}
# Group by both dimensions
cat1grp <- aggregate(freqdata$CNT, list(freqdata$CAT1), FUN=sum)
cat2grp <- aggregate(freqdata$CNT, list(freqdata$CAT2), FUN=sum)
# Create lookup from cat1 group (rows)
lkp1 <- cat1grp$x
names(lkp1) <- cat1grp$Group.1
# Create lookup from cat2 group (columns)
lkp2 <- cat2grp$x
names(lkp2) <- cat2grp$Group.1
# Assign data to new variable
dt <- freqdata
# Create freq columns for both dimensions
dt$rowcnt <- lkp1[dt$CAT1]
dt$colcnt <- lkp2[dt$CAT2]
# Create percentages for both dimensions
#dt$Percentage <- dt$Percentage
dt$rowpct <- dt$CNT / dt$rowcnt * 100
dt$colpct <- dt$CNT / dt$colcnt * 100
# Transpose Frequency statistics
dt1 <- reshape(dt, timevar = "CAT2", idvar = "CAT1",
v.names = "CNT", direction = "wide",
drop = c("PCT", "rowcnt", "colcnt", "rowpct", "colpct"))
dt1$Total <- lkp1[dt1$CAT1]
dt1$Order <- 1
dt1$Statistic <- "Frequency"
names(dt1) <- gsub("CNT.", "", names(dt1), fixed = TRUE)
# Transpose Percents
dt2 <- NULL
if (!option_true(options, "nopercent", FALSE)) {
dt2 <- reshape(dt, timevar = "CAT2", idvar = "CAT1",
v.names = "PCT", direction = "wide",
drop = c("CNT", "rowcnt", "colcnt", "rowpct", "colpct"))
dt2$Total <- lkp1[dt1$CAT1] / sum(lkp1, na.rm = TRUE) * 100
dt2$Order <- 2
dt2$Statistic <- "Percent"
names(dt2) <- gsub("PCT.", "", names(dt2), fixed = TRUE)
}
# Transpose Row Percents
dt3 <- NULL
if (!option_true(options, "norow", FALSE)) {
dt3 <- reshape(dt, timevar = "CAT2", idvar = "CAT1",
v.names = "rowpct", direction = "wide",
drop = c("PCT", "rowcnt", "colcnt", "CNT", "colpct"))
dt3$Total <- NA
dt3$Order <- 3
dt3$Statistic <- "Row Pct"
names(dt3) <- gsub("rowpct.", "", names(dt3), fixed = TRUE)
}
# Transpose Col Percents
dt4 <- NULL
if (!option_true(options, "nocol", FALSE)) {
dt4 <- reshape(dt, timevar = "CAT2", idvar = "CAT1",
v.names = "colpct", direction = "wide",
drop = c("PCT", "rowcnt", "colcnt", "CNT", "rowpct"))
dt4$Total <- NA
dt4$Order <- 4
dt4$Statistic <- "Col Pct"
names(dt4) <- gsub("colpct.", "", names(dt4), fixed = TRUE)
}
#browser()
dt5 <- NULL
dt6 <- NULL
# Add row total if requested
if (option_true(options, "totrow", TRUE)) {
dt5 <- data.frame(CAT1 = "Total")
for (nm in names(lkp2)) {
dt5[[nm]] <- lkp2[[nm]]
}
dt5$Total = sum(lkp2, na.rm = TRUE)
dt5$Order = 1
dt5$Statistic = "Frequency"
if (!option_true(options, "nopercent", FALSE)) {
dt6 <- data.frame(CAT1 = "Total")
for (nm in names(lkp2)) {
dt6[[nm]] <- lkp2[[nm]] / sum(lkp2, na.rm = TRUE) * 100
}
dt6$Total = 100
dt6$Order = 2
dt6$Statistic = "Percent"
}
}
# Combine everthing
ret <- rbind(dt1, dt2, dt3, dt4,
make.row.names = FALSE,
stringsAsFactors = FALSE)
# Get all value column names
nnms <- names(ret)[!names(ret) %in% c("CAT1", "Order", "Statistic")]
# Sort data frame by category and order
ret <- ret[order(ret$CAT1, ret$Order), c("CAT1", "Statistic", nnms) ]
# Make sure total rows are at the end, after the sort
if (!is.null(dt5) & !is.null(dt6)) {
ret <- rbind(ret,
dt5[, c("CAT1", "Statistic", nnms)],
dt6[, c("CAT1", "Statistic", nnms)],
make.row.names = FALSE, stringsAsFactors = FALSE)
} else if (!is.null(dt5)) {
ret <- rbind(ret,
dt5[, c("CAT1", "Statistic", nnms)],
make.row.names = FALSE, stringsAsFactors = FALSE)
}
# Kill rownames
rownames(ret) <- NULL
# Rename to Category so output_report() will recognize as a stub
names(ret)[1] <- "CAT"
# Get format
fmt <- get_option(options, "format", "%.2f")
# Create formatting list
lst <- list(Frequency = "%d", Percent = fmt,
'Row Pct' = fmt, 'Col Pct' = fmt)
fl <- as.flist(lst, type = "row", lookup = ret$Statistic)
# Assign flist to data columns
fmts <- list()
for (nm in nnms) {
fmts[[nm]] <- fl
}
formats(ret) <- fmts
# Kill column total if requested
if (!option_true(options, "totcol", TRUE)) {
ret$Total <- NULL
}
# Assign label to Category
attr(ret$CAT, "label") <- lbl1
# Add spanning headers
if (!is.null(bylbl)) {
lbl <- paste0(bylbl, "Table of ", var1, " by ", var2)
} else {
lbl <- paste0("Table of ", var1, " by ", var2)
}
spn2 <- span(1, ncol(ret), label = lbl, level = 2)
spn1 <- span(3, ncol(ret), label = lbl2, level = 1)
attr(ret, "spans") <- list(spn1, spn2)
# Add footnote for missing values
if (!has_option(options, "missing")) {
fa <- attr(freqdata, "footnotes")
if (!is.null(fa)) {
attr(ret, "footnotes") <- fa
}
}
return(ret)
}
get_output_oneway <- function(data, tb, weight = NULL, options = NULL,
by = NULL, shape = "wide", stats = NULL,
order = "") {
# Get frequencies
ret <- freq_oneway(data = data, tb = tb, weight = weight,
options = options, stats = stats, out = TRUE,
order = order)
# Bind variable name
tmp <- list(VAR = tb)
df <- as.data.frame(tmp, stringsAsFactors = FALSE)
ret <- cbind(df, ret)
# Bind by variables
if (!is.null(by)) {
tmp <- list()
for(nm in names(by)) {
tmp[[nm]] <- by[nm]
}
df <- as.data.frame(tmp, stringsAsFactors = FALSE)
rownames(df) <- NULL
ret <- cbind(df, ret)
}
nms <- names(ret)
if (!is.null(shape)) {
if (shape == "long") {
ret <- proc_transpose(ret, copy = c(names(by), "VAR"),
id = "CAT", name = "STAT", log = FALSE)
} else if (all(shape == "stacked")) {
ret <- proc_transpose(ret, name = "STAT",
by = c(names(by), "VAR", "CAT"), log = FALSE)
rnms <- names(ret)
rnms[rnms %in% "COL1"] <- "VALUES"
names(ret) <- rnms
}
}
return(ret)
}
get_output_twoway <- function(data, tb1, tb2, weight, options, out = FALSE,
by = NULL, shape = "wide", stats = NULL, order = "") {
ret <- freq_twoway(data = data, tb1 = tb1, tb2 = tb2, weight = weight,
options = options, out = out, stats = stats, order = order)
# Bind variable names
tmp <- list(VAR1 = tb1, VAR2 = tb2)
df <- as.data.frame(tmp, stringsAsFactors = FALSE)
ret <- cbind(df, ret)
if (!is.null(by)) {
tmp <- list()
for(nm in names(by)) {
tmp[[nm]] <- by[nm]
}
df <- as.data.frame(tmp, stringsAsFactors = FALSE)
rownames(df) <- NULL
ret <- cbind(df, ret)
}
nms <- names(ret)
if (!is.null(shape)) {
if (shape == "long") {
ret <- proc_transpose(ret, id = c("CAT1", "CAT2"),
copy = c(names(by), "VAR1", "VAR2"),
name = "STAT", log = FALSE)
} else if (all(shape == "stacked")) {
ret <- proc_transpose(ret, name = "STAT",
by = c(names(by), "VAR1", "VAR2", "CAT1", "CAT2"),
log = FALSE)
rnms <- names(ret)
rnms[rnms %in% "COL1"] <- "VALUES"
names(ret) <- rnms
}
}
return(ret)
}
#' @import common
get_output_specs <- function(tbls, outs, opts, output) {
ret <- list()
sts <- c("n", "cnt", "pct", "cumsum", "cumpct")
if (length(outs) >= 1) {
for (nm in names(outs)) {
if ("out_req" %in% class(outs[[nm]])) {
if (outs[[nm]]$report %eq% TRUE) {
ret[[nm]] <- outs[[nm]]
} else if (is.null(outs[[nm]]$table)) {
ot <- outs[[nm]]
tnms <- names(tbls)
if (is.null(tnms))
tnms <- tbls
for (i in seq_len(length(tbls))) {
if (length(tbls) == 1) {
tnm <- nm
} else {
tnm <- tnms[[i]]
if (tnm == "")
tnm <- tbls[[i]]
}
ot$table <- tbls[[i]]
if (is.null(ot$shape))
ot$shape <- "wide"
ret[[tnm]] <- ot
}
} else {
ot <- outs[[nm]]
if (is.null(ot$shape))
ot$shape = "wide"
ret[[nm]] <- ot
}
} else {
warning("proc_freq: Unknown parameter '" %p% nm %p% "'")
}
}
} else {
tnms <- names(tbls)
if (is.null(tnms))
tnms <- tbls
for (i in seq_len(length(tbls))) {
nm <- tnms[[i]]
if (nm == "")
nm <- tbls[[i]]
if (option_true(output, "long", FALSE)) {
ret[[nm]] <- out_spec(table = tbls[[i]], stats = sts, shape = "long")
} else if (option_true(output, "stacked", FALSE)) {
ret[[nm]] <- out_spec(table = tbls[[i]], stats = sts, shape = "stacked")
} else {
ret[[nm]] <- out_spec(table = tbls[[i]], stats = sts, shape = "wide")
}
}
}
return(ret)
}
get_nlevels <- function(data, var1, var2 = NULL, byvars = NULL,
out = FALSE, missing = FALSE) {
ret <- NULL
vars <- c(var1)
l1miss <- NULL
l2miss <- NULL
if (missing) {
l1vals <- data[[var1]]
l1miss <- sum(any(is.na(data[[var1]])))
} else {
l1vals <- data[[var1]][!is.na(data[[var1]])]
}
lvls <- c(length(unique(l1vals)))
lbl <- ""
if (!is.null(var2)) {
if (missing) {
l2vals <- data[[var2]]
l2miss <- sum(any(is.na(data[[var2]])))
} else
l2vals <- data[[var2]][!is.na(data[[var2]])]
}
if (out) {
if (!is.null(var2)) {
if (missing) {
l2cnt <- length(unique(l2vals))
ret <- data.frame(VAR1 = lvls, VAR1.MISS = l1miss,
VAR1.NONMISS = lvls - l1miss,
VAR2 = l2cnt, VAR2.MISS = l2miss,
VAR2.NONMISS = l2cnt - l2miss,
stringsAsFactors = FALSE)
labels(ret) <- list(VAR1 = var1, VAR2 = var2,
VAR1.MISS = var1 %p% "Missing Levels",
VAR1.NONMISS = var1 %p% "Nonmissing Levels",
VAR2.MISS = var2 %p% "Missing Levels",
VAR2.NONMISS = var2 %p% "Nonmissing Levels"
)
} else {
ret <- data.frame(VAR1 = lvls, VAR2 = length(unique(l2vals)),
stringsAsFactors = FALSE)
labels(ret) <- list(VAR1 = var1, VAR2 = var2)
}
} else {
if (missing) {
ret <- data.frame(VAR = lvls, MISS = l1miss, NONMISS = lvls - l1miss,
stringsAsFactors = FALSE)
labels(ret) <- list(VAR = var1, MISS = "Missing Levels",
NONMISS = "Nonmissing Levels")
} else {
ret <- data.frame(VAR = lvls, stringsAsFactors = FALSE)
labels(ret) <- list(VAR = var1)
}
}
bv <- list()
if (!is.null(byvars)) {
if (length(byvars) == 1)
nms <- "BY"
else
nms <- paste0("BY", seq_len(length(byvars)))
for (i in seq_along(nms)) {
bv[[nms[[i]]]] <- byvars[[names(byvars)[[i]]]]
}
bret <- as.data.frame(bv, stringsAsFactors = FALSE)
labels(bret) <- names(byvars)
ret <- cbind(bret, ret)
lbl <- paste0(byvars, collapse = "")
}
} else {
if (!is.null(var2)) {
vars[2] <- var2
lvls[2] <- length(unique(l2vals))
}
if (!missing) {
ret <- data.frame(stub = vars, levels = lvls, stringsAsFactors = FALSE)
labels(ret) <- list(stub = "Variable", levels = "Levels")
} else {
if (!is.null(var2)) {
mcnt <- c(l1miss, l2miss)
nmcnt <- c(lvls[1] - l1miss, lvls[2] - l2miss)
} else {
mcnt <- l1miss
nmcnt <- lvls[1] - l1miss
}
ret <- data.frame(stub = vars, levels = lvls,
MISS = mcnt, NONMISS = nmcnt,
stringsAsFactors = FALSE)
labels(ret) <- list(stub = "Variable", levels = "Levels",
MISS = "Missing Levels",
NONMISS = "Nonmissing Levels")
}
lbl <- gsub(",", "", byvars, fixed = TRUE)
}
# Add spanning headers
if (!is.null(byvars)) {
spn2 <- span(1, ncol(ret), label = lbl, level = 1)
# spn1 <- span(1, ncol(ret), label = "Number of Variable Levels", level = 2)
attr(ret, "spans") <- list(spn2)
} else {
# lbl <- paste0("Table of ", var1, " by ", var2)
# spn2 <- span(1, ncol(ret), label = lbl, level = 2)
# #spn1 <- span(1, ncol(ret), label = "Number of Variable Levels", level = 1)
# attr(ret, "spans") <- list(spn1)
}
return(ret)
}
# Zero Fill -------------------------------------------------------------
# Appends missing combination to data frame and
# adds a variable __cnt by which you can count correctly.
get_nway_zero_fills <- function(data, outs, by = NULL, weight = NULL, options = NULL) {
if (option_true(options, "nosparse", FALSE) ) {
if (is.null(weight))
data[["__cnt"]] <- 1
else
data[["__cnt"]] <- data[[weight]]
ret <- data
} else {
# Get table variable vectors
if ("list" %in% class(outs))
ots <- get_output_tables(outs)
else
ots <- outs
# Split into vectors
tbls <- get_table_list(ots)
# Set count value on existing records
if (is.null(weight)) {
data[["__cnt"]] <- 1
} else {
data[["__cnt"]] <- data[[weight]]
}
ret <- data
for (i in seq_len(length(tbls))) {
tb <- tbls[[i]]
v1 <- list()
# Get unique values of target var
for (i in seq_len(length(tb))) {
if (is.factor(data[[tb[i]]])) {
v1[[tb[i]]] <- levels(data[[tb[i]]])
} else {
v1[[tb[i]]] <- names(sort(table(as.character(data[[tb[i]]]))))
}
}
# Get unique by values
if (!is.null(by)) {
for (i in seq_len(length(by))) {
if (is.factor(data[[by[i]]])) {
v1[[by[i]]] <- levels(data[[by[i]]])
} else {
v1[[by[i]]] <- names(sort(table(as.character(data[[by[i]]]))))
}
}
}
# Expand combinations
ex <- expand.grid(v1, stringsAsFactors = FALSE)
if (nrow(ex) > 0) {
# Zero fill combinations
ex[["__cnt"]] <- 0
# Merge combinations onto original data
ret <- merge(ret, ex, sort = FALSE, all = TRUE)
}
}
}
return(ret)
}
get_table_list <- function(tbls) {
ret <- NULL
if (!is.null(tbls)) {
ret <- strsplit(tbls, "*", fixed = TRUE)
for (i in seq_len(length(ret))) {
ret[[i]] <- trimws(ret[[i]])
}
}
return(ret)
}
get_output_tables <- function(outs) {
ret <- c()
if (!is.null(outs)) {
for (ot in outs) {
ret[length(ret) + 1] <- ot[["table"]]
}
}
return(ret)
}
# Drivers -----------------------------------------------------------------
#' @import fmtr
gen_report_freq <- function(data,
by = NULL,
tables = NULL,
options = NULL,
weight = NULL,
view = TRUE,
titles = NULL,
order = NULL,
plots = NULL) {
res <- list()
# print("Orig print_location")
# print(print_location)
# browser()
# Deal with sparse option
dta <- get_nway_zero_fills(data, tables, by, weight, options)
wgt <- "__cnt"
bylbls <- c()
if (!is.null(by)) {
lst <- unclass(dta)[by]
for (nm in names(lst))
lst[[nm]] <- as.factor(lst[[nm]])
dtlst <- split(dta, lst, sep = "|", drop = TRUE)
snms <- strsplit(names(dtlst), "|", fixed = TRUE)
for (k in seq_len(length(snms))) {
for (l in seq_len(length(by))) {
lv <- ""
if (!is.null(bylbls[k])) {
if (!is.na(bylbls[k])) {
lv <- bylbls[k]
}
}
bylbls[k] <- paste0(lv, by[l], "=", snms[[k]][l], ", ")
}
}
} else {
dtlst <- list(dta)
}
# Loop through by groups
for (j in seq_len(length(dtlst))) {
# Get table for this by group
dt <- dtlst[[j]]
# Loop through table requests
for (i in seq_len(length(tables))) {
nm <- names(tables)[i]
tb <- tables[i]
#browser()
#out <- i == length(tables) & has_option(options, "out")
crstab <- NULL
chisq <- NULL
fisher <- NULL
nlevels <- NULL
plotres <- NULL
# Split cross variables
splt <- trimws(strsplit(tb, "*", fixed = TRUE)[[1]])
# Perform either one-way or two-way frequency count
if (length(splt) == 1) {
# Assign new label if there are by groups
if (length(bylbls[j]) > 0) {
if (!is.null(attr(data[[tb]], "label")))
attr(dt[[tb]], "label") <- paste0(bylbls[j], attr(data[[tb]], "label"))
else
attr(dt[[tb]], "label") <- paste0(bylbls[j], tb)
}
# Deal with ordering
if (order == "data") {
dt[[tb]] <- factor(dt[[tb]], levels = unique(data[[tb]]))
} else if (order == "formatted") {
fmt1 <- formats(data)[[tb]]
if (!is.null(fmt1)) {
if ("fmt" %in% class(fmt1)) {
attr(fmt1, "as.factor") <- TRUE
dt[[tb]] <- fapply(dt[[tb]], fmt1)
}
}
}
# Perform one-way frequency
result <- freq_oneway(dt, tb, wgt, options, out = FALSE, order = order)
# Get nlevels if requested
if (has_option(options, "nlevels")) {
nlevels <- get_nlevels(dt, tb, byvars = bylbls[j],
missing = has_option(options, "missing"))
}
if (!is.null(plots)) {
plotres <- render_freqplot(result, tb, plt = plots[[i]])
}
} else if (length(splt) == 2) {
bylbl <- NULL
if (length(bylbls[j]) > 0) {
bylbl <- bylbls[j]
}
# Deal with ordering
if (order == "data") {
dt[[splt[1]]] <- factor(dt[[splt[1]]], levels = unique(data[[splt[1]]]))
dt[[splt[2]]] <- factor(dt[[splt[2]]], levels = unique(data[[splt[2]]]))
} else if (order == "formatted") {
fmt1 <- formats(data)[[splt[1]]]
if (!is.null(fmt1)) {
if ("fmt" %in% class(fmt1)) {
attr(fmt1, "as.factor") <- TRUE
dt[[splt[1]]] <- fapply(dt[[splt[1]]], fmt1)
}
}
fmt2 <- formats(data)[[splt[2]]]
if (!is.null(fmt2)) {
if ("fmt" %in% class(fmt2)) {
attr(fmt2, "as.factor") <- TRUE
dt[[splt[2]]] <- fapply(dt[[splt[2]]], fmt2)
}
}
}
# Perform two-way frequency
result <- freq_twoway(dt, splt[1], splt[2], wgt, options,
out = FALSE, order = order)
if (!has_option(options, "list")) {
# Perform cross tab by default
crstab <- cross_tab(result, options, splt[1], splt[2], bylbl)
}
if (get_option(options, "fisher", FALSE)) {
if (!is.null(wgt))
fisher <- get_fisher(dt[[splt[1]]], dt[[splt[[2]]]], dt[[wgt]],
bylbl = bylbls[j])
else
fisher <- get_fisher(dt[[splt[1]]], dt[[splt[[2]]]],
bylbl = bylbls[j])
}
if (get_option(options, "chisq", FALSE)) {
if (!is.null(wgt))
chisq <- get_chisq(dt[[splt[1]]], dt[[splt[[2]]]], dt[[wgt]],
bylbl = bylbls[j])
else
chisq <- get_chisq(dt[[splt[1]]], dt[[splt[[2]]]], bylbl = bylbls[j])
}
# Get nlevels if requested
if (has_option(options, "nlevels")) {
nlevels <- get_nlevels(dt, splt[1], splt[2], byvars = bylbls[j],
missing = has_option(options, "missing"))
}
if (!is.null(plots)) {
plotres <- render_freqplot(result, splt[1], splt[2], plots[[i]])
}
} else {
stop("Procedure does not yet support n-way frequencies.")
}
# Cast to tibble if incoming data was a tibble
if ("tbl_df" %in% class(data)) {
if (!is.null(crstab))
crstab <- as_tibble(crstab)
if (!is.null(result))
result <- as_tibble(result)
if (!is.null(fisher))
fisher <- as_tibble(fisher)
if (!is.null(chisq))
chisq <- as_tibble(chisq)
if (!is.null(nlevels))
nlevels <- as_tibble(nlevels)
}
if (!is.null(nlevels)) {
res[[paste0("Nlevels:", get_name(nm, tb, bylbls[j]))]] <- nlevels
}
# If a cross tab was produced, add it to result
if (!is.null(crstab)) {
res[[get_name(nm, tb, bylbls[j])]] <- crstab
# if ("out" %in% names(options) & i == length(tables)) {
#
# res[[get_name(options[["out"]], "", bylbls[j])]] <- result
# }
} else { # Otherwise add list to result
res[[get_name(nm, tb, bylbls[j])]] <- result
}
if (!is.null(chisq)) {
res[[get_name("Chisq", tb, bylbls[j])]] <- chisq
}
if (!is.null(fisher)) {
res[[get_name("Fisher", tb, bylbls[j])]] <- fisher
}
if (!is.null(plots)) {
res[[get_name("Plots", tb, bylbls[j], addvar = TRUE)]] <- plotres
}
}
}
gv <- options("procs.print")[[1]]
if (is.null(gv))
gv <- TRUE
# Create viewer report if requested
if (gv) {
if (view == TRUE && interactive()) {
vrfl <- tempfile()
if (is.null(titles)) {
titles <- "The FREQ Function"
}
out <- output_report(res, dir_name = dirname(vrfl),
file_name = basename(vrfl), out_type = "HTML",
titles = titles, margins = .5, viewer = TRUE)
show_viewer(out)
}
}
return(res)
}
gen_output_freq <- function(data,
by = NULL,
tables = NULL,
options = NULL,
weight = NULL,
output = NULL,
order = NULL,
rename = NULL,
keep = NULL,
drop = NULL) {
# Deal with sparse option
dta <- get_nway_zero_fills(data, output, by, weight, options)
wgt <- "__cnt"
byvals <- list()
bynms <- NULL
if (!is.null(by)) {
if (length(by) == 1)
bynms <- "BY"
else
bynms <- paste0("BY", seq(1, length(by)))
bylbls <- setNames(by, bynms)
lst <- unclass(dta)[by]
for (nm in names(lst))
lst[[nm]] <- as.factor(lst[[nm]])
dtlst <- split(dta, lst, sep = "|")
snms <- strsplit(names(dtlst), "|", fixed = TRUE)
for (k in seq_len(length(snms))) {
byvals[[k]] <- snms[[k]]
names(byvals[[k]]) <- bynms
}
} else {
dtlst <- list(dta)
}
res <- list()
if (length(output) > 0) {
for (nm in names(output)) {
# print("Orig print_location")
# print(print_location)
# browser()
outp <- output[[nm]]
tb <- outp$table
tmpres <- NULL
chisq <- NULL
fisher <- NULL
nlevels <- NULL
# Loop through by groups
for (j in seq_len(length(dtlst))) {
# Get table for this by group
dt <- dtlst[[j]]
if (nrow(dt) > 0 || has_option(options, "nosparse") == FALSE) {
crstab <- NULL
tmpchisq <- NULL
tmpfisher <- NULL
tmpnlevels <- NULL
# Split cross variables
splt <- trimws(strsplit(tb, "*", fixed = TRUE)[[1]])
# Perform either one-way or two-way frequency count
if (length(splt) == 1) {
# Deal with ordering
if (order == "data") {
dt[[tb]] <- factor(dt[[tb]], levels = unique(data[[tb]]))
} else if (order == "formatted") {
fmt1 <- formats(data)[[tb]]
if (!is.null(fmt1)) {
if ("fmt" %in% class(fmt1)) {
attr(fmt1, "as.factor") <- TRUE
dt[[tb]] <- fapply(dt[[tb]], fmt1)
}
}
}
if (length(byvals) >= j) {
result <- get_output_oneway(dt, tb, wgt, options,
byvals[[j]], shape = outp$shape,
stats = outp$stats, order = order)
} else {
result <- get_output_oneway(dt, tb, wgt, options,
NULL, shape = outp$shape,
stats = outp$stats, order = order)
}
if (has_option(options, "nlevels")) {
if (length(byvals) >= j) {
tmpnlevels <- get_nlevels(dt, tb, byvars = byvals[[j]], out = TRUE,
missing = has_option(options, "missing"))
} else {
tmpnlevels <- get_nlevels(dt, tb, byvars = NULL, out = TRUE,
missing = has_option(options, "missing"))
}
}
} else if (length(splt) == 2) {
# Deal with ordering
if (order == "data") {
dt[[splt[1]]] <- factor(dt[[splt[1]]], levels = unique(data[[splt[1]]]))
dt[[splt[2]]] <- factor(dt[[splt[2]]], levels = unique(data[[splt[2]]]))
} else if (order == "formatted") {
fmt1 <- formats(data)[[splt[1]]]
if (!is.null(fmt1)) {
if ("fmt" %in% class(fmt1)) {
attr(fmt1, "as.factor") <- TRUE
dt[[splt[1]]] <- fapply(dt[[splt[1]]], fmt1)
}
}
fmt2 <- formats(data)[[splt[2]]]
if (!is.null(fmt2)) {
if ("fmt" %in% class(fmt2)) {
attr(fmt2, "as.factor") <- TRUE
dt[[splt[2]]] <- fapply(dt[[splt[2]]], fmt2)
}
}
}
if (has_option(options, "crosstab")) {
result <- freq_twoway(dt, splt[1], splt[2], wgt, options,
out = FALSE, order = order)
result <- cross_tab(result, options, splt[1], splt[2], "")
} else {
# Perform two-way frequency
if (length(byvals) >= j) {
result <- get_output_twoway(dt, splt[1], splt[2], wgt, options,
byvals[[j]], shape = outp$shape,
out = TRUE, stats = outp$stats, order = order)
} else {
result <- get_output_twoway(dt, splt[1], splt[2], wgt, options,
NULL, shape = outp$shape,
out = TRUE, stats = outp$stats, order = order)
}
}
if (has_option(options, "nlevels")) {
if (length(byvals) >= j) {
tmpnlevels <- get_nlevels(dt, splt[1], splt[2],
byvars = byvals[[j]], out = TRUE,
missing = has_option(options, "missing"))
} else {
tmpnlevels <- get_nlevels(dt, splt[1], splt[2],
byvars = NULL, out = TRUE,
missing = has_option(options, "missing"))
}
}
if (!is.null(outp$stats)) {
if (option_true(options, "fisher", FALSE)) {
if (!is.null(wgt))
tmpfisher <- get_fisher(dt[[splt[1]]], dt[[splt[[2]]]], dt[[wgt]],
bylbl = byvals[j], output = TRUE)
else
tmpfisher <- get_fisher(dt[[splt[1]]], dt[[splt[[2]]]],
bylbl = byvals[j], output = TRUE)
if (is.null(fisher))
fisher <- tmpfisher
else
fisher <- rbind(fisher, tmpfisher)
}
if (option_true(options, "chisq", FALSE)) {
if (!is.null(wgt))
tmpchisq <- get_chisq(dt[[splt[1]]], dt[[splt[[2]]]], dt[[wgt]],
bylbl = byvals[j], output = TRUE)
else
tmpchisq <- get_chisq(dt[[splt[1]]], dt[[splt[[2]]]],
bylbl = byvals[j], output = TRUE)
if (is.null(chisq))
chisq <- tmpchisq
else
chisq <- rbind(chisq, tmpchisq)
}
}
} else {
stop("Procedure does not yet support n-way frequencies.")
}
# Cast to tibble if incoming data was a tibble
if ("tbl_df" %in% class(data)) {
if (!is.null(result))
result <- as_tibble(result)
if (!is.null(chisq))
chisq <- as_tibble(chisq)
if (!is.null(fisher))
fisher <- as_tibble(fisher)
if (!is.null(nlevels))
nlevels <- as_tibble(nlevels)
}
if (has_option(options, "nlevels")) {
if (is.null(nlevels))
nlevels <- tmpnlevels
else
nlevels <- rbind(nlevels, tmpnlevels)
}
if (!is.null(tmpres))
tmpres <- rbind(tmpres, result)
else
tmpres <- result
}
}
if (!is.null(by)) {
tmpres <- restore_datatypes(tmpres, data, by, bynms)
labels(tmpres) <- bylbls
}
# System Labels
#labels(tmpres) <- append(mlbls, bylbls)
# User labels
if (!is.null(outp$label))
labels(tmpres) <- outp$label
# Formats
if (!is.null(outp$format))
formats(tmpres) <- outp$format
# Assign to output
if (!is.null(has_option(options, "nlevels")))
res[[paste0("NLevels:", nm)]] <- nlevels
if (!has_option(options, "notable")) {
# Select the rename/keep/drop vector that aligns with this table request
tidx <- match(nm, names(output))
trename <- get_table_vector(rename, nm, tidx)
tkeep <- get_table_vector(keep, nm, tidx)
tdrop <- get_table_vector(drop, nm, tidx)
# Perform rename operation
tmpres <- rename_data(tmpres, trename)
# Perform keep operation
tmpres <- keep_data(tmpres, tkeep)
# Perform drop operation
tmpres <- drop_data(tmpres, tdrop)
res[[nm]] <- tmpres
}
if (!is.null(chisq)) {
if (!is.null(by))
labels(chisq) <- bylbls
res[[paste0("chisq:", nm)]] <- chisq
}
if (!is.null(fisher)) {
if (!is.null(by))
labels(fisher) <- bylbls
res[[paste0("fisher:", nm)]] <- fisher
}
}
}
# Rename CAT/BY columns to original variable names from labels
if (has_option(options, "varnames")) {
for (nm in names(res)) {
df <- res[[nm]]
if (is.data.frame(df)) {
nms <- names(df)
for (i in seq_along(nms)) {
if (grepl("^(CAT|BY)\\d*$", nms[i])) {
lbl <- attr(df[[nms[i]]], "label")
if (!is.null(lbl)) {
nms[i] <- lbl
}
}
}
names(res[[nm]]) <- nms
}
}
}
return(res)
}
# Plots -------------------------------------------------------------------
Try the procs package in your browser
Any scripts or data that you put into this service are public.
procs documentation built on Nov. 2, 2026, 5:06 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions gen_output_freq gen_report_freq get_output_tables get_table_list get_nway_zero_fills get_nlevels get_output_specs get_output_twoway get_output_oneway cross_tab freq_twoway freq_oneway log_freq proc_freq
Documented in proc_freq
# Proc Freq ---------------------------------------------------------------
#' @title Generates Frequency Statistics
#' @encoding UTF-8
#' @description The \code{proc_freq} function generates frequency statistics.
#' It is both an interactive function that can be used for data exploration,
#' and can produce dataset output for further analysis.
#' The function can perform one and two-way frequencies. Two-way
#' frequencies are produced as a cross-tabulation by default. There
#' are many options to control the generated tables. The function will return
#' requested tables in a named list.
#' @details
#' The \code{proc_freq} function generates frequency statistics
#' for one-way and two-way tables. Data is passed in on the \code{data}
#' parameter. The desired frequencies are specified on the \code{tables}
#' parameter.
#'
#' @section Report Output:
#' By default, \code{proc_freq} results will
#' be immediately sent to the viewer as an HTML report. This functionality
#' makes it easy to get a quick analysis of your data with very little
#' effort. To turn off the interactive report, pass the "noprint" keyword
#' to the \code{options} parameter or set \code{options("procs.print" = FALSE)}.
#'
#' The \code{titles} parameter allows you to set one or more titles for your
#' report. Pass these titles as a vector of strings.
#'
#' If the frequency variables have a label assigned, that label
#' will be used in the report output. This feature gives you some control
#' over the column headers in the final report.
#'
#' The exact datasets used for the interactive output can be returned as a list.
#' To return these datasets as a list, pass
#' the "report" keyword on the \code{output} parameter. This list may in
#' turn be passed to \code{\link{proc_print}} to write the report to a file.
#'
#' @section Data Frame Output:
#' The \code{proc_freq} function returns output datasets.
#' If you are requesting only one table, a single
#' data frame will be returned. If you request multiple tables, a list of data
#' frames will be returned.
#'
#' By default, the list items are named according to the
#' strings specified on the \code{tables} parameter. You may control
#' the names of the returned results by using a named vector on the
#' \code{tables} parameter.
#'
#' The standard output datasets are optimized for data manipulation.
#' Column names have been standardized, and additional variables may
#' be present to help with data manipulation. For instance, the by variable will
#' always be named "BY", and the frequency category will always be named "CAT".
#' In addition, data values in the
#' output datasets are not rounded or formatted
#' to give you the most accurate statistical results.
#'
#' @section Frequency Weight:
#' Normally the \code{proc_freq} function counts each row in the
#' input data equally. In some cases, however, each row in the data
#' can represent multiple observations, and rows should not be treated
#' equally. In these cases, use the \code{weight} parameter. The parameter
#' accepts a variable/column name to use as the weighted value. If the
#' \code{weight} parameter is used, the function will sum the weighted values
#' instead of counting rows.
#'
#' @section By Groups:
#' You may request that frequencies be separated into by groups using the
#' \code{by} parameter. The parameter accepts one or more variable names
#' from the input dataset. When this parameter is assigned, the data
#' will be subset by the "by" variable(s) before frequency counts are
#' calculated. On the interactive report, the by groups will appear in
#' separate tables. On the output dataset, the by groups will be identified
#' by additional columns.
#'
#' @section Options:
#' The \code{options} parameter accepts a vector of options. Normally, these
#' options must be quoted. But you may pass them unquoted using the \code{v()}
#' function. For example, you can request the number of category levels
#' and the Chi-Square statistic like this: \code{options = v(nlevels, chisq)}.
#'
#' Below are all the available options and a description of each:
#' \itemize{
#' \item{\strong{crosstab}: Two-way output tables are a list style by default.
#' If you want a crosstab style, pass the "crosstab" option.
#' }
#' \item{\strong{list}: Two-way interactive tables are a crosstab style
#' by default. If you want a list style two-way table, pass the "list" option.
#' }
#' \item{\strong{missing}: Normally, missing values are not counted and not
#' shown on frequency tables. The "missing" option allows you to treat
#' missing (NA) values as normal values, so that they are counted and
#' shown on the frequency table. Missing levels will appear on the
#' table as a single dot (".").
#' }
#' \item{\strong{nlevels}: The "nlevels" option will display the number of unique
#' values for each variable in the frequency table. These levels are generated
#' as a separate table that appears on the report, and will also be output from
#' the function as a separate dataset.
#' }
#' \item{\strong{nocol}: Two-way cross tabulation tables include column percents
#' by default. To turn them off, pass the "nocol" option.
#' }
#' \item{\strong{nocum}: Whether to include the cumulative frequency and percent
#' columns on one-way, interactive tables. These columns are included by default.
#' To turn them off, pass the "nocum" option.
#' }
#' \item{\strong{nofreq}: The "nofreq" option will remove the frequency column
#' from one-way and two-way tables.
#' }
#' \item{\strong{nopercent}: The "nopercent" option will remove the percent column
#' from one-way and two-way tables.
#' }
#' \item{\strong{noprint}: Whether to print the interactive report to the
#' viewer. By default, the report is printed to the viewer. The "noprint"
#' option will inhibit printing.
#' }
#' \item{\strong{nonobs}: Whether to include the number of observations "N"
#' column on the output and interactive tables. By default, the N column
#' will be included. The "nonobs" option turns it off.
#' }
#' \item{\strong{norow}: Whether to include the row percentages on two-way
#' crosstab tables. The "norow" option will turn them off.
#' }
#' \item{\strong{nosparse/sparse}: Whether to include categories for which there are no
#' frequency counts. Zero-count categories will be included by default, which
#' is the "sparse" option. If the
#' "nosparse" option is present, zero-count categories will be removed.
#' }
#' \item{\strong{notable}: Whether to include the frequency table in the output
#' dataset list. Normally, the frequency table is included. You may want to
#' exclude the frequency table in some cases, for instance, if you only
#' want the Chi-Square statistic.
#' }
#' \item{\strong{outcum}: Whether to include the cumulative frequency and percent
#' on output frequency tables. By default, these columns are not included.
#' The "outcum" option will include them.
#' }
#' \item{\strong{outpct}: Whether to include row and column percentages on
#' two-way output datasets. When specified, two columns are added to the
#' output dataset: "PCT_ROW", which contains the row percentage for each
#' cell, and "PCT_COL", which contains the column percentage for each cell.
#' This option is only meaningful for two-way interactions; for one-way
#' frequency tables it is silently ignored.
#' }
#' \item{\strong{varnames}: Replaces the standardized "CAT" and "BY" output
#' column names with the original variable names from which those columns
#' are derived. The variable names are taken from the column labels.
#' This option only affects data frame output, not the interactive report.
#' }
#' }
#' @section Statistics Options:
#' In addition to the above options, the \code{options} parameter accepts
#' some statistics options. The following keywords will generate
#' an additional tables of specialized statistics. These statistics
#' options are only available on two-way tables:
#' \itemize{
#' \item{\strong{chisq}: Requests that the Chi-square statistics be produced.
#' }
#' \item{\strong{fisher}: Requests that the Fisher's exact statistics be produced.
#' }
#' }
#' @section Using Factors:
#' There are some occasions when you may want to define the \code{tables} variable
#' or \code{by} variables as a factor. One occasion is for sorting/ordering,
#' and the other is for obtaining zero-counts on sparse data.
#'
#' To order the frequency categories in the frequency output, define the
#' \code{tables} variable as a factor in the desired order. The function will
#' then retain that order for the frequency categories in the output dataset
#' and report.
#'
#' You may also wish to
#' define the tables variable as a factor if you are dealing with sparse data
#' and some of the frequency categories are not present in the data. To ensure
#' these categories are displayed with zero-counts, define the \code{tables} variable
#' or \code{by} variable
#' as a factor and use the "sparse" option. Note
#' that the "sparse" option is actually the default.
#'
#' If you do not want to
#' show the zero-count categories on a variable that is defined as a factor,
#' pass the "nosparse" keyword on the \code{options} parameter.
#'
#' @section Ordering Frequency Output:
#' Frequency output can be ordered using the \code{order} parameter. There are
#' several choices:
#' \itemize{
#' \item{\strong{internal}: The internal or "natural" order of the table variables.
#' For character variables, "internal" means alphabetical order. For factors,
#' "internal" means by order of the levels.}
#' \item{\strong{data}: "data" order is different from "internal" order. "data"
#' order means the order that the data appears in the incoming data frame, which
#' may or may not be the same as the "internal" order. This
#' choice essentially sorts the frequencies according to however the
#' table variable values were encountered in the incoming data.}
#' \item{\strong{freq}: The "freq" order value means to sort the output in
#' descending frequency order.}
#' \item{\strong{formatted}: If there is a format assigned to the table variable(s),
#' you may also use "formatted" order. "formatted" order means to apply the
#' format to the table variable(s) and then sort the frequencies according to the
#' order specified in the format. The format should be a user-defined
#' format as defined in the \strong{fmtr} package.}
#' }
#' Note that the \code{order} parameter applies to both the interactive report
#' and the data frame output. This behavior is different from SAS, which only
#' orders the interactive report. The behavior of the \code{order} parameter was
#' modified to reduce subsequent sorts and make it more convenient for the user.
#' @section Data Shaping:
#' By default, the \code{proc_freq} function returns an output dataset of
#' frequency results. If running interactively, the function also prints
#' the frequency results to the viewer. As described above, the output
#' dataset can be somewhat different than the dataset sent to the viewer.
#' The \code{output} parameter allows you to choose which datasets to return,
#' and how those datasets are structured.
#'
#' There are three choices of datasets:
#' "out", "report", and "none". The "out" keyword returns the default output
#' dataset. The "report" keyword returns the dataset(s) sent to the viewer. You
#' may also pass "none" if you don't want any datasets returned from the function.
#'
#' In addition, the output dataset produced by the "out" keyword can be shaped
#' in different ways. These shaping options allow you to decide whether the
#' data should be returned long and skinny, or short and wide. The shaping
#' options can reduce the amount of data manipulation necessary to get the
#' frequencies into the desired form. The
#' shaping options are as follows:
#' \itemize{
#' \item{\strong{long}: Transposes the output datasets
#' so that statistics are in rows and frequency categories are in columns.
#' }
#' \item{\strong{stacked}: Requests that output datasets
#' be returned in "stacked" form, such that both statistics and frequency
#' categories are in rows.
#' }
#' \item{\strong{wide}: Requests that output datasets
#' be returned in "wide" form, such that statistics are across the top in
#' columns, and frequency categories are in rows. This shaping option
#' is the default.
#' }
#' }
#' @section Plots:
#' The \code{proc_freq} function can generate plots. These plots
#' can be most easily generated by setting \code{plots = TRUE}. The default
#' plots are bar charts showing the frequency counts for each category
#' and each table request. For two-way interactions, the function will
#' plot a bar chart for each interaction.
#'
#' In addition to standard bar charts, the function can produce dot plots, stacked
#' bar charts, and clustered bar charts. To request these types of plots, pass
#' a \code{\link{freqplot}} function to the \code{plots} parameter. The
#' \code{\link{freqplot}} function provides several optional parameters for customizing
#' your chart. See the \code{\link{freqplot}} documentation for a full
#' list of options and more plot examples.
#' @param data The input data frame to perform frequency calculations on.
#' Input data as the first parameter makes this function pipe-friendly.
#' @param tables The variable or variables to perform frequency counts on.
#' The table specifications are passed as a vector of strings. For one-way
#' frequencies, simply pass the variable name.
#' For two-way tables, pass the desired combination of variables separated by a
#' star (*) operator. The parameter does not accept SAS® style grouping syntax.
#' All cross combinations should be listed explicitly. If the
#' table request is named, the name will be used as the list item name on the
#' return list of tables. See "Example 3" for an illustration on how to name an
#' output table.
#' @param output Whether or not to return datasets from the function. Valid
#' values are "out", "none", and "report". Default is "out". This parameter
#' also accepts the data shaping options "long", "stacked", and "wide". See
#' the \strong{Data Shaping} section for a description of these options. Multiple
#' output keywords may be passed on a character vector. For example,
#' to produce both a report dataset and a "long" output dataset,
#' use the parameter \code{output = c("report", "out", "long")}.
#' @param by An optional by group. Parameter accepts a vector of one or more
#' variable names. When this parameter is set, data
#' will be subset for each by group, and tables will be generated for
#' each subset.
#' @param weight An optional weight parameter. This parameter is passed
#' as a variable name to use for the weight. If a weight variable is
#' indicated, the weighted value will be summed to calculate the frequency
#' counts.
#' @param options The options desired for the function.
#' Options are passed to the parameter as a vector of quoted strings. You may
#' also use the \code{v()} function to pass unquoted strings.
#' The following options are available:
#' "chisq", "crosstab", "fisher", "list", "missing",
#' "nlevels", "nocol",
#' "nocum", "nofreq", "nopercent", "noprint",
#' "nonobs", "norow", "nosparse", "notable", "outcum", "outpct", "varnames". See
#' the \strong{Options} section for a description of these options.
#' @param titles A vector of titles to assign to the interactive report.
#' @param order Indicates how to order the function output. Options are "internal",
#' "formatted", "freq" and "data". Default is "internal". See the section
#' on "Ordering Frequency Output" for more information on this parameter.
#' @param plots Pass the desired plot(s) on this parameter. Valid values are TRUE,
#' NULL, or a call to the \code{\link{freqplot}} function. Default is NULL,
#' meaning no
#' plots are desired. The value TRUE will give a default frequency plot for each
#' table request. If there are multiple table requests, you can pass a single
#' plot request which will apply to all tables, or a list of plot requests that
#' align one-to-one for each table request.
#' @param where An expression to filter the rows before the frequencies are
#' calculated. Use the \code{\link[base]{expression}} function to define
#' the filter.
#' @return The function will return all requested datasets by default. This is
#' equivalent to the \code{output = "out"} option. To return the datasets
#' as created for the interactive report, pass the "report" output option. If
#' no output datasets are desired, pass the "none" output option. If a
#' single dataset is requested, the function
#' will return a single dataset. If multiple datasets are requested, the function
#' will return a list of datasets. The type of data frame returned will
#' correspond to the type of data frame passed in on the \code{data} parameter.
#' If the input data is a tibble, the output data will be a
#' tibble. If the input data is a Base R data frame, the output data will be
#' a Base R data frame.
#' @param rename A named vector of variables to rename on the frequency output
#' dataset(s), where the name is the existing variable name and the value is
#' the desired new name. If there are multiple tables, you may supply one
#' rename vector for all tables, or a list of vectors, one for each table.
#' If using a list of vectors, they may either be named or unnamed. If named,
#' names should match the table names. The rename vector will only apply to
#' the frequency output dataset(s), not the interactive report, report
#' datasets, nlevels, or any statistical output. The rename operation is
#' performed before the \code{keep} and \code{drop} operations, so the
#' \code{keep} and \code{drop} vectors should reference the new variable names.
#' @param keep A vector of variables to keep on the frequency output dataset(s). If there
#' are multiple tables, you may supply one keep vector for all tables, or
#' a list of vectors, one for each table. If using a list of vectors, they
#' may either be named or unnamed. If named, names should match the table names.
#' The keep vector will only apply to the frequency output dataset(s), not
#' the interactive report, report datasets, nlevels, or any statistical output.
#' @param drop A vector of variables to drop from the frequency output dataset(s). If there
#' are multiple tables, you may supply one drop vector for all tables, or
#' a list of vectors, one for each table. If using a list of vectors, they
#' may either be named or unnamed. If named, names should match the table names.
#' The drop vector will only apply to the frequency output dataset(s), not
#' the interactive report, report datasets, nlevels, or any statistical output.
#' If both \code{keep} and \code{drop} are supplied, \code{keep} is applied first.
#' @seealso For summary statistics, see \code{\link{proc_means}}. To pivot
#' or transpose the data coming from \code{proc_freq},
#' see \code{\link{proc_transpose}}. For frequency plots,
#' see \code{\link{freqplot}}.
#' @examples
#' library(procs)
#'
#' # Turn off printing for CRAN checks
#' options("procs.print" = FALSE)
#'
#' # Create sample data
#' df <- as.data.frame(HairEyeColor, stringsAsFactors = FALSE)
#'
#' # Assign labels
#' labels(df) <- list(Hair = "Hair Color",
#' Eye = "Eye Color",
#' Sex = "Sex at Birth")
#'
#' # Example #1: One way frequencies on Hair and Eye color with weight option.
#' res <- proc_freq(df,
#' tables = v(Hair, Eye),
#' options = outcum,
#' weight = Freq)
#'
#' # View result data
#' res
#' # $Hair
#' # VAR CAT N CNT PCT CUMSUM CUMPCT
#' # 1 Hair Black 592 108 18.24324 108 18.24324
#' # 2 Hair Blond 592 127 21.45270 235 39.69595
#' # 3 Hair Brown 592 286 48.31081 521 88.00676
#' # 4 Hair Red 592 71 11.99324 592 100.00000
#' #
#' # $Eye
#' # VAR CAT N CNT PCT CUMSUM CUMPCT
#' # 1 Eye Blue 592 215 36.31757 215 36.31757
#' # 2 Eye Brown 592 220 37.16216 435 73.47973
#' # 3 Eye Green 592 64 10.81081 499 84.29054
#' # 4 Eye Hazel 592 93 15.70946 592 100.00000
#'
#' # Example #2: 2 x 2 Crosstabulation table with Chi-Square statistic
#' res <- proc_freq(df, tables = Hair * Eye,
#' weight = Freq,
#' options = v(crosstab, chisq))
#'
#' # View result data
#' res
#' #$`Hair * Eye`
#' # Category Statistic Blue Brown Green Hazel Total
#' #1 Black Frequency 20.000000 68.000000 5.0000000 15.000000 108.00000
#' #2 Black Percent 3.378378 11.486486 0.8445946 2.533784 18.24324
#' #3 Black Row Pct 18.518519 62.962963 4.6296296 13.888889 NA
#' #4 Black Col Pct 9.302326 30.909091 7.8125000 16.129032 NA
#' #5 Blond Frequency 94.000000 7.000000 16.0000000 10.000000 127.00000
#' #6 Blond Percent 15.878378 1.182432 2.7027027 1.689189 21.45270
#' #7 Blond Row Pct 74.015748 5.511811 12.5984252 7.874016 NA
#' #8 Blond Col Pct 43.720930 3.181818 25.0000000 10.752688 NA
#' #9 Brown Frequency 84.000000 119.000000 29.0000000 54.000000 286.00000
#' #10 Brown Percent 14.189189 20.101351 4.8986486 9.121622 48.31081
#' #11 Brown Row Pct 29.370629 41.608392 10.1398601 18.881119 NA
#' #12 Brown Col Pct 39.069767 54.090909 45.3125000 58.064516 NA
#' #13 Red Frequency 17.000000 26.000000 14.0000000 14.000000 71.00000
#' #14 Red Percent 2.871622 4.391892 2.3648649 2.364865 11.99324
#' #15 Red Row Pct 23.943662 36.619718 19.7183099 19.718310 NA
#' #16 Red Col Pct 7.906977 11.818182 21.8750000 15.053763 NA
#' #17 Total Frequency 215.000000 220.000000 64.0000000 93.000000 592.00000
#' #18 Total Percent 36.317568 37.162162 10.8108108 15.709459 100.00000
#'
#' # $`chisq:Hair * Eye`
#' # STAT DF VAL PROB
#' # 1 Chi-Square 9 138.2898 2.325287e-25
#' # 2 Continuity Adj. Chi-Square 9 138.2898 2.325287e-25
#'
#' # Example #3: By variable with named table request
#' res <- proc_freq(df, tables = v(Hair, Eye, Cross = Hair * Eye),
#' by = Sex,
#' weight = Freq)
#'
#' # View result data
#' res
#' # $Hair
#' # BY VAR CAT N CNT PCT
#' # 1 Female Hair Black 313 52 16.61342
#' # 2 Female Hair Blond 313 81 25.87859
#' # 3 Female Hair Brown 313 143 45.68690
#' # 4 Female Hair Red 313 37 11.82109
#' # 5 Male Hair Black 279 56 20.07168
#' # 6 Male Hair Blond 279 46 16.48746
#' # 7 Male Hair Brown 279 143 51.25448
#' # 8 Male Hair Red 279 34 12.18638
#' #
#' # $Eye
#' # BY VAR CAT N CNT PCT
#' # 1 Female Eye Blue 313 114 36.421725
#' # 2 Female Eye Brown 313 122 38.977636
#' # 3 Female Eye Green 313 31 9.904153
#' # 4 Female Eye Hazel 313 46 14.696486
#' # 5 Male Eye Blue 279 101 36.200717
#' # 6 Male Eye Brown 279 98 35.125448
#' # 7 Male Eye Green 279 33 11.827957
#' # 8 Male Eye Hazel 279 47 16.845878
#' #
#' # $Cross
#' # BY VAR1 VAR2 CAT1 CAT2 N CNT PCT
#' # 1 Female Hair Eye Black Blue 313 9 2.8753994
#' # 2 Female Hair Eye Black Brown 313 36 11.5015974
#' # 3 Female Hair Eye Black Green 313 2 0.6389776
#' # 4 Female Hair Eye Black Hazel 313 5 1.5974441
#' # 5 Female Hair Eye Blond Blue 313 64 20.4472843
#' # 6 Female Hair Eye Blond Brown 313 4 1.2779553
#' # 7 Female Hair Eye Blond Green 313 8 2.5559105
#' # 8 Female Hair Eye Blond Hazel 313 5 1.5974441
#' # 9 Female Hair Eye Brown Blue 313 34 10.8626198
#' # 10 Female Hair Eye Brown Brown 313 66 21.0862620
#' # 11 Female Hair Eye Brown Green 313 14 4.4728435
#' # 12 Female Hair Eye Brown Hazel 313 29 9.2651757
#' # 13 Female Hair Eye Red Blue 313 7 2.2364217
#' # 14 Female Hair Eye Red Brown 313 16 5.1118211
#' # 15 Female Hair Eye Red Green 313 7 2.2364217
#' # 16 Female Hair Eye Red Hazel 313 7 2.2364217
#' # 17 Male Hair Eye Black Blue 279 11 3.9426523
#' # 18 Male Hair Eye Black Brown 279 32 11.4695341
#' # 19 Male Hair Eye Black Green 279 3 1.0752688
#' # 20 Male Hair Eye Black Hazel 279 10 3.5842294
#' # 21 Male Hair Eye Blond Blue 279 30 10.7526882
#' # 22 Male Hair Eye Blond Brown 279 3 1.0752688
#' # 23 Male Hair Eye Blond Green 279 8 2.8673835
#' # 24 Male Hair Eye Blond Hazel 279 5 1.7921147
#' # 25 Male Hair Eye Brown Blue 279 50 17.9211470
#' # 26 Male Hair Eye Brown Brown 279 53 18.9964158
#' # 27 Male Hair Eye Brown Green 279 15 5.3763441
#' # 28 Male Hair Eye Brown Hazel 279 25 8.9605735
#' # 29 Male Hair Eye Red Blue 279 10 3.5842294
#' # 30 Male Hair Eye Red Brown 279 10 3.5842294
#' # 31 Male Hair Eye Red Green 279 7 2.5089606
#' # 32 Male Hair Eye Red Hazel 279 7 2.5089606
#'
#' # Example #4: Default Plots
#' res <- proc_freq(df, tables = v(Hair, Eye, Cross = Hair * Eye),
#' weight = Freq,
#' plots = TRUE, # Request default plots
#' output = report # So we can see plot objects
#' )
#'
#' # View results
#' # Frequency plots are created for each table
#' res
#' # $Hair
#' # CAT N CNT PCT CUMSUM CUMPCT
#' # 1 Black 592 108 18.24324 108 18.24324
#' # 2 Blond 592 127 21.45270 235 39.69595
#' # 3 Brown 592 286 48.31081 521 88.00676
#' # 4 Red 592 71 11.99324 592 100.00000
#' #
#' # $`Plots: Hair`
#' # # A plot specification:
#' # - path: 'C:\Users\dbosa\AppData\Local\Temp\RtmpOYrg1Y\file5dfa8212f57c7.jpg'
#' # - height: 4.5
#' # - width: 6
#' #
#' # $Eye
#' # CAT N CNT PCT CUMSUM CUMPCT
#' # 1 Blue 592 215 36.31757 215 36.31757
#' # 2 Brown 592 220 37.16216 435 73.47973
#' # 3 Green 592 64 10.81081 499 84.29054
#' # 4 Hazel 592 93 15.70946 592 100.00000
#' #
#' # $`Plots: Eye`
#' # # A plot specification:
#' # - path: 'C:\Users\dbosa\AppData\Local\Temp\RtmpOYrg1Y\file5dfa854b429fc.jpg'
#' # - height: 4.5
#' # - width: 6
#' #
#' # $Cross
#' # CAT Statistic Blue Brown Green Hazel Total
#' # 1 Black Frequency 20.000000 68.000000 5.0000000 15.000000 108.00000
#' # 2 Black Percent 3.378378 11.486486 0.8445946 2.533784 18.24324
#' # 3 Black Row Pct 18.518519 62.962963 4.6296296 13.888889 NA
#' # 4 Black Col Pct 9.302326 30.909091 7.8125000 16.129032 NA
#' # 5 Blond Frequency 94.000000 7.000000 16.0000000 10.000000 127.00000
#' # 6 Blond Percent 15.878378 1.182432 2.7027027 1.689189 21.45270
#' # 7 Blond Row Pct 74.015748 5.511811 12.5984252 7.874016 NA
#' # 8 Blond Col Pct 43.720930 3.181818 25.0000000 10.752688 NA
#' # 9 Brown Frequency 84.000000 119.000000 29.0000000 54.000000 286.00000
#' # 10 Brown Percent 14.189189 20.101351 4.8986486 9.121622 48.31081
#' # 11 Brown Row Pct 29.370629 41.608392 10.1398601 18.881119 NA
#' # 12 Brown Col Pct 39.069767 54.090909 45.3125000 58.064516 NA
#' # 13 Red Frequency 17.000000 26.000000 14.0000000 14.000000 71.00000
#' # 14 Red Percent 2.871622 4.391892 2.3648649 2.364865 11.99324
#' # 15 Red Row Pct 23.943662 36.619718 19.7183099 19.718310 NA
#' # 16 Red Col Pct 7.906977 11.818182 21.8750000 15.053763 NA
#' # 17 Total Frequency 215.000000 220.000000 64.0000000 93.000000 592.00000
#' # 18 Total Percent 36.317568 37.162162 10.8108108 15.709459 100.00000
#' #
#' # $`Plots: Hair * Eye`
#' # # A plot specification:
#' # - path: 'C:\Users\dbosa\AppData\Local\Temp\RtmpOYrg1Y\file5dfa87b6a3303.jpg'
#' # - height: 4.5
#' # - width: 6
#'
#' @import fmtr
#' @import tibble
#' @import common
#' @export
proc_freq <- function(data,
tables = NULL,
output = NULL,
by = NULL,
weight = NULL,
options = NULL,
titles = NULL,
order = "internal",
plots = NULL,
where = NULL,
rename = NULL,
keep = NULL,
drop = NULL
) {
# Allow single-value NSE on some parameters
by <- resolve_arg(by)
tables <- resolve_arg(tables)
weight <- resolve_arg(weight)
options <- resolve_arg(options)
output <- resolve_arg(output)
order <- resolve_arg(order)
# Parameter checks
if (!"data.frame" %in% class(data)) {
stop("Input data is not a data frame.")
}
if (nrow(data) == 0) {
stop("Input data has no rows.")
}
nms <- names(data)
if (!is.null(by)) {
if (!all(by %in% nms)) {
stop(paste("Invalid by name: ", by[!by %in% nms], "\n"))
}
}
if (!is.null(weight)) {
if (!all(weight %in% nms)) {
stop(paste("Invalid weight name: ", weight[!weight %in% nms], "\n"))
}
}
if (!is.null(tables)) {
locs <- grepl("*", tables, fixed = TRUE)
slocs <- unlist(strsplit(tables[locs], "*", fixed = TRUE))
vars <- c(tables[!locs], trimws(slocs))
vars <- unique(vars)
if (!all(vars %in% nms)) {
stop(paste("Invalid tables name: ", vars[!vars %in% nms], "\n"))
}
}
if (!is.null(output)) {
outs <- c("out", "report", "none", "wide", "long", "stacked")
if (!all(tolower(output) %in% outs)) {
stop(paste("Invalid output keyword: ", output[!tolower(output) %in% outs], "\n"))
}
}
if (!is.null(options)) {
kopts <- c("noprint",
"list", "nocol", "nocum", "nofreq", "nopercent",
"norow", "nosparse", "outcum",
"sparse", "crosstab",
"notable", "nonobs", "missing", "nlevels",
"outpct", # Output percentage options
"chisq", "fisher", # Statistics options
"alpha", # Setting options
"varnames" # Column naming options
)
# Future options
# "expected", "outexpect", "missprint", "cl", "maxlevels"
if (!all(tolower(options) %in% kopts)) {
stop(paste("Invalid options keyword: ", options[!tolower(options) %in% kopts], "\n"))
}
}
# Default order parameter
if (is.null(order)) {
order <- "internal"
} else {
order <- tolower(order)
if (!order %in% c("data", "internal", "formatted", "freq")) {
stop(paste0("Invalid value for 'order' parameter: '", order, "'\n",
"Valid values are: 'internal', 'freq', 'formatted', and 'data'"))
}
}
# Prepare plots for easier processing
if (!is.null(plots)) {
if ("logical" %in% class(plots)) {
plots <- "freqplot"
}
if (all(class(plots) == "list")) {
# Do nothing
} else if ("freqplot" %in% class(plots) |
"character" %in% class(plots)) {
tplots <- list()
for (idx in seq_along(tables)) {
tplots[[idx]] <- plots
}
plots <- tplots
}
}
# Set default statistics for output parameters
if (has_output(output))
outreq <- get_output_specs(tables, list(), options, output)
else
outreq <- NULL
# Deal with where expression
if (!is.null(where)) {
data <- subset_data(data, where)
}
rptflg <- FALSE
rptnm <- ""
if (has_report(output)) {
rptflg <- TRUE
}
if (has_view(options))
view <- TRUE
else
view <- FALSE
rptres <- NULL
res <- NULL
if (view | rptflg) {
rptres <- gen_report_freq(data = data,
by = by,
tables = tables,
options = options,
weight = weight,
view = view,
titles = titles,
order = order,
plots = plots)
}
if (length(outreq) > 0) {
res <- gen_output_freq(data = data,
by = by,
tables = tables,
options = options,
weight = weight,
output = outreq,
order = order,
rename = rename,
keep = keep,
drop = drop)
}
# Add report list if requested
if (rptflg & !is.null(rptres)) {
if (is.null(res))
res <- rptres
else {
res <- list(out = res, report = rptres)
}
}
log_freq(data = data, by = by, tables = tables, options = options, output = output,
weight = weight, view = view, titles = titles, order = order, where = where,
plots = plots, outcnt = length(res))
# If only one dataset returned, remove list
if (length(res) == 1) {
res <- res[[1]]
}
if (log_output()) {
log_logr(res)
return(res)
}
return(res)
}
log_freq <- function(data,
by = NULL,
tables = NULL,
output = NULL,
options = NULL,
weight = NULL,
view = TRUE,
titles = NULL,
order = NULL,
where = NULL,
plots = NULL,
outcnt = NULL) {
ret <- c()
indt <- " "
ret <- paste0("proc_freq: input data set ", nrow(data),
" rows and ", ncol(data), " columns")
if (!is.null(tables))
ret[length(ret) + 1] <- paste0(indt, "tables: ",
paste(tables, collapse = " "))
if (!is.null(by))
ret[length(ret) + 1] <- paste0(indt, "by: ", paste(by, collapse = " "))
if (!is.null(output))
ret[length(ret) + 1] <- paste0(indt, "output: ", paste(output, collapse = " "))
if (!is.null(weight))
ret[length(ret) + 1] <- paste0(indt, "weight: ", paste(weight, collapse = " "))
if (!is.null(view))
ret[length(ret) + 1]<- paste0(indt, "view: ", paste(view, collapse = ""))
if (!is.null(titles))
ret[length(ret) + 1] <- paste0(indt, "titles: ", paste(titles, collapse = "\n"))
if (!is.null(order))
ret[length(ret) + 1] <- paste0(indt, "order: ", paste(order, collapse = " "))
if (!is.null(where))
ret[length(ret) + 1] <- paste0(indt, "where: ", as.character(where))
if (!is.null(plots)) {
if ("logical" %in% class(plots)) {
ret[length(ret) + 1] <- paste0(indt, "plots: ", as.character(plots))
} else {
ret[length(ret) + 1] <- paste0(indt, "plots: ", "(object)")
}
}
if (!is.null(outcnt))
ret[length(ret) + 1] <- paste0(indt, "output: ", outcnt, " datasets")
plts <- freqplot(type = "dotplot")
log_logr(ret)
}
# Sub Procedures ----------------------------------------------------------
#' @import fmtr
#' @import stats
#' @import reporter
#' @import common
#' @noRd
freq_oneway <- function(data, tb, weight, options, out = FALSE, stats = NULL,
order = "") {
if (is.null(stats))
stats <- c("n", "cnt", "pct", "cumsum", "cumpct")
# Get target variable vector
var <- data[[tb]]
if (has_option(options, "missing")) {
if (is.factor(var)) {
nmiss <- sum(is.na(var))
if (nmiss > 0) {
var <- as.character(var)
var <- ifelse(is.na(var), ".", var)
}
} else {
var <- ifelse(is.na(var), ".", var)
}
}
# Get frequency counts
if (is.null(weight)) {
categories <- names(sort(table(var)))
frequencies <- as.vector(sort(table(var)))
} else {
if (nrow(data) == 0) {
cnts <- 0
categories <- ""
frequencies <- 0
} else {
cnts <- aggregate(data[[weight]], list(var), FUN = sum)
if (nrow(cnts) == 0) {
categories <- ""
frequencies <- 0
} else {
categories <- cnts$Group.1
frequencies <- cnts$x
}
}
}
# Perform calculations
n <- sum(frequencies, na.rm = TRUE)
percentages <- frequencies / n * 100
# Create result data frame
result <- data.frame("CAT" = categories,
"N" = n,
"CNT" = frequencies,
"PCT" = percentages,
stringsAsFactors = FALSE)
# Frequency order
if (order == "freq") {
result <- sort(result, by = "CNT", ascending = FALSE)
rownames(result) <- NULL
}
# Apply cumulative sums and percents
result$CUMSUM <- cumsum(result$CNT)
result$CUMPCT <- cumsum(result$PCT)
# Get any existing label for target variable
lbl <- attr(data[[tb]], "label")
if (is.null(lbl))
lbl <- tb
# Clear out any names
names(tb) <- NULL
# Apply default labels
labels(result) <- c(CAT= tb,
CNT = "Frequency",
PCT = "Percent",
CUMSUM = "Cumulative Frequency",
CUMPCT = "Cumulative Percent")
# Apply default formats
formats(result) <- list(CUMPCT = "%.2f",
PCT = "%.2f")
# browser()
if (option_true(options, "nonobs", FALSE) |
!"n" %in% stats) {
result[["N"]] <- NULL
}
# Kill freq if requested
if (option_true(options, "nofreq", FALSE) |
!"cnt" %in% stats) {
result[["CNT"]] <- NULL
}
# Kill pct if requested
if (option_true(options, "nopercent", FALSE) |
!"pct" %in% stats) {
result[["PCT"]] <- NULL
}
# Kill cum freq if requested
if ((out == FALSE & option_true(options, "nocum", FALSE)) |
(out == TRUE & !option_true(options, "outcum", FALSE))) {
result[["CUMSUM"]] <- NULL
}
# Kill cum pct if requested
if ((out == FALSE & option_true(options, "nocum", FALSE)) |
(out == TRUE & !option_true(options, "outcum", FALSE))) {
result[["CUMPCT"]] <- NULL
}
if (!is.null(stats)) {
# mp <- c(n = "N", cnt = "Frequency", pct = "Percent",
# cumsum = "Cum_Freq", cumpct = "Cum_Pct")
fstats <- stats[toupper(stats) %in% names(result)]
result <- result[ , c("CAT", toupper(fstats))]
}
# Add spanning headers
spn <- span(1, ncol(result), label = paste("Table of", lbl), level = 1)
attr(result, "spans") <- list(spn)
# Add footnote for missing values
if (!has_option(options, "missing")) {
nas <- is.na(data[[tb]])
if (!is.null(weight)) {
nacnts <- sum(data[[weight]][nas])
} else {
nacnts <- sum(nas)
}
if (nacnts > 0) {
ftns <- ftn("Frequency Missing = " %p% nacnts, align = "center",
blank_row = "none", borders = "all")
attr(result, "footnotes") <- list(ftns)
}
}
return(result)
}
#' @import fmtr
#' @import stats
#' @import common
#' @noRd
freq_twoway <- function(data, tb1, tb2, weight, options,
out = FALSE, stats = NULL, order = "") {
if (is.null(stats))
stats <- c("n", "cnt", "pct", "cumsum", "cumpct")
# Assign 1 to count column
if (is.null(weight) | weight != "__cnt")
data[["__cnt"]] <- 1
l1 <- NULL
l2 <- NULL
# Get target variables into vectors
if (is.factor(data[[tb1]])) {
l1 <- levels(data[[tb1]])
v1 <- as.character(data[[tb1]])
} else {
v1 <- data[[tb1]]
}
if (is.factor(data[[tb2]])) {
l2 <- levels(data[[tb2]])
v2 <- as.character(data[[tb2]])
} else {
v2 <- data[[tb2]]
}
# Deal with missing
if (has_option(options, "missing")) {
if (is.factor(v1)) {
nmiss <- sum(is.na(v1))
if (nmiss > 0) {
v1 <- as.character(v1)
v1 <- ifelse(is.na(v1), ".", v1)
}
} else {
v1 <- ifelse(is.na(v1), ".", v1)
}
if (is.factor(v2)) {
nmiss <- sum(is.na(v2))
if (nmiss > 0) {
v2 <- as.character(v2)
v2 <- ifelse(is.na(v2), ".", v2)
}
} else {
v2 <- ifelse(is.na(v2), ".", v2)
}
}
# Get unique values of variables
t1 <- names(sort(table(v1)))
t2 <- names(sort(table(v2)))
# Get unique combinations of variable values for zero-fill
ex <- expand.grid(tb1 = t1, tb2 = t2, stringsAsFactors = FALSE)
# Assign zero fill value
ex[["__cnt"]] <- 0
# Use weight variable if requested
if (is.null(weight)) {
c1 <- data[["__cnt"]]
} else {
c1 <-data[[weight]]
}
# Append zero fills
if (!option_true(options, "nosparse", FALSE)) {
c1 <- append(c1, ex[["__cnt"]])
v1 <- append(v1, ex[["tb1"]])
v2 <- append(v2, ex[["tb2"]])
}
# Get frequencies
cnts <- aggregate(c1, list(v1, v2), FUN = sum)
categories1 <- cnts$Group.1
categories2 <- cnts$Group.2
frequencies <- cnts$x
# Perform calculations
n <- sum(frequencies, na.rm = TRUE)
percentages <- frequencies / n * 100
# Create result data frame
result <- data.frame("CAT1" = categories1,
"CAT2" = categories2,
"N" = n,
"CNT" = frequencies,
"PCT" = percentages,
stringsAsFactors = FALSE)
# Deal with frequency sort
if (order == "freq") {
cnt1 <- aggregate(result[["CNT"]], list(result[["CAT1"]]), FUN = sum)
cnt2 <- aggregate(result[["CNT"]], list(result[["CAT2"]]), FUN = sum)
l1 <- sort(cnt1, by = "x", ascending = FALSE)[["Group.1"]]
l2 <- sort(cnt2, by = "x", ascending = FALSE)[["Group.1"]]
}
# Restore factors if necessary
if (!is.null(l1)) {
result$CAT1 <- factor(result$CAT1, levels = l1)
}
if (!is.null(l2)) {
result$CAT2 <- factor(result$CAT2, levels = l2)
}
# Sort result data frame
result <- sort(result, by = c("CAT1", "CAT2"))
# Kill rownames
rownames(result) <- NULL
result$CUMSUM = cumsum(result$CNT)
result$CUMPCT = cumsum(result$PCT)
# Compute row/column percentages for outpct option (two-way output only)
pct_row_col <- NULL
if (out && has_option(options, "outpct")) {
cat1totals <- aggregate(result$CNT, list(as.character(result$CAT1)), FUN = sum)
cat2totals <- aggregate(result$CNT, list(as.character(result$CAT2)), FUN = sum)
lkp_row <- cat1totals$x
names(lkp_row) <- cat1totals$Group.1
lkp_col <- cat2totals$x
names(lkp_col) <- cat2totals$Group.1
pct_row_col <- data.frame(
PCT_ROW = result$CNT / lkp_row[as.character(result$CAT1)] * 100,
PCT_COL = result$CNT / lkp_col[as.character(result$CAT2)] * 100,
stringsAsFactors = FALSE
)
rownames(pct_row_col) <- NULL
}
# Get labels on target variables if they exist
lbl1 <- attr(data[[tb1]], "label")
lbl2 <- attr(data[[tb2]], "label")
if (is.null(lbl1))
lbl1 <- tb1
if (is.null(lbl2))
lbl2 <- tb2
# Assign labels
labels(result) <- c(CAT1 = lbl1,
CAT2 = lbl2,
CNT = "Frequency",
PCT = "Percent",
CUMSUM = "Cumulative Frequency",
CUMPCT = "Cumulative Percent")
# Assign default formats
formats(result) <- list(PCT = paste0("%.4f"),
CUMPCT = paste0("%.4f"))
if (out == FALSE |
option_true(options, "nonobs", FALSE) | !"n" %in% stats) {
result[["N"]] <- NULL
}
# Kill freq if requested
if (option_true(options, "nofreq", FALSE) |
!"cnt" %in% stats) {
result[["CNT"]] <- NULL
}
# Kill pct if requested
if (option_true(options, "nopercent", FALSE) |
!"pct" %in% stats) {
result[["PCT"]] <- NULL
}
# Kill cum freq if requested
if (out == FALSE & option_true(options, "nocum"))
result[["CUMSUM"]] <- NULL
else if (out & !option_true(options, "outcum", FALSE)) {
result[["CUMSUM"]] <- NULL
}
# Kill cum pct if requested
if (out == FALSE & option_true(options, "nocum"))
result[["CUMPCT"]] <- NULL
else if (out & !option_true(options, "outcum", FALSE)) {
result[["CUMPCT"]] <- NULL
}
if (!is.null(stats)) {
# mp <- c(n = "N", cnt = "Frequency", pct = "Percent",
# cumsum = "Cum_Freq", cumpct = "Cum_Pct")
fstats <- stats[toupper(stats) %in% names(result)]
result <- result[ , c("CAT1", "CAT2", toupper(fstats))]
}
# Append PCT_ROW and PCT_COL if outpct was requested
if (!is.null(pct_row_col)) {
rownames(result) <- NULL
result <- cbind(result, pct_row_col)
labels(result) <- c(PCT_ROW = "Row Percent", PCT_COL = "Column Percent")
formats(result) <- list(PCT_ROW = "%.4f", PCT_COL = "%.4f")
}
# Add footnote for missing values
if (!has_option(options, "missing")) {
nas1 <- is.na(data[[tb1]])
nas2 <- is.na(data[[tb2]])
if (!is.null(weight)) {
na1cnts <- sum(data[[weight]][nas1])
na2cnts <- sum(data[[weight]][nas2])
} else {
na1cnts <- sum(nas1)
na2cnts <- sum(nas2)
}
if ((na1cnts + na2cnts) > 0) {
ftns <- ftn("Frequency Missing = " %p% (na1cnts + na2cnts),
align = "center",
blank_row = "none", borders = "all")
attr(result, "footnotes") <- list(ftns)
}
}
return(result)
}
#' @import fmtr
#' @import stats
#' @import common
#' @noRd
cross_tab <- function(freqdata, options, var1, var2, bylbl = NULL) {
lbl1 <- attr(freqdata$CAT1, "label")
lbl2 <- attr(freqdata$CAT2, "label")
#browser()
if (has_option(options, "missing")) {
v1 <- freqdata$CAT1
v2 <- freqdata$CAT2
if (is.factor(v1)) {
nmiss <- sum(is.na(v1))
if (nmiss > 0) {
v1 <- as.character(v1)
v1 <- ifelse(is.na(v1), ".", v1)
}
} else {
v1 <- ifelse(is.na(v1), ".", v1)
}
if (is.factor(v2)) {
nmiss <- sum(is.na(v2))
if (nmiss > 0) {
v2 <- as.character(v2)
v2 <- ifelse(is.na(v2), ".", v2)
}
} else {
v2 <- ifelse(is.na(v2), ".", v2)
}
freqdata$CAT1 <- v1
freqdata$CAT2 <- v2
}
nms <- names(freqdata)
if ("CUMSUM" %in% nms) {
freqdata$CUMSUM <- NULL
}
if ("CUMPCT" %in% nms) {
freqdata$CUMPCT <- NULL
}
# Group by both dimensions
cat1grp <- aggregate(freqdata$CNT, list(freqdata$CAT1), FUN=sum)
cat2grp <- aggregate(freqdata$CNT, list(freqdata$CAT2), FUN=sum)
# Create lookup from cat1 group (rows)
lkp1 <- cat1grp$x
names(lkp1) <- cat1grp$Group.1
# Create lookup from cat2 group (columns)
lkp2 <- cat2grp$x
names(lkp2) <- cat2grp$Group.1
# Assign data to new variable
dt <- freqdata
# Create freq columns for both dimensions
dt$rowcnt <- lkp1[dt$CAT1]
dt$colcnt <- lkp2[dt$CAT2]
# Create percentages for both dimensions
#dt$Percentage <- dt$Percentage
dt$rowpct <- dt$CNT / dt$rowcnt * 100
dt$colpct <- dt$CNT / dt$colcnt * 100
# Transpose Frequency statistics
dt1 <- reshape(dt, timevar = "CAT2", idvar = "CAT1",
v.names = "CNT", direction = "wide",
drop = c("PCT", "rowcnt", "colcnt", "rowpct", "colpct"))
dt1$Total <- lkp1[dt1$CAT1]
dt1$Order <- 1
dt1$Statistic <- "Frequency"
names(dt1) <- gsub("CNT.", "", names(dt1), fixed = TRUE)
# Transpose Percents
dt2 <- NULL
if (!option_true(options, "nopercent", FALSE)) {
dt2 <- reshape(dt, timevar = "CAT2", idvar = "CAT1",
v.names = "PCT", direction = "wide",
drop = c("CNT", "rowcnt", "colcnt", "rowpct", "colpct"))
dt2$Total <- lkp1[dt1$CAT1] / sum(lkp1, na.rm = TRUE) * 100
dt2$Order <- 2
dt2$Statistic <- "Percent"
names(dt2) <- gsub("PCT.", "", names(dt2), fixed = TRUE)
}
# Transpose Row Percents
dt3 <- NULL
if (!option_true(options, "norow", FALSE)) {
dt3 <- reshape(dt, timevar = "CAT2", idvar = "CAT1",
v.names = "rowpct", direction = "wide",
drop = c("PCT", "rowcnt", "colcnt", "CNT", "colpct"))
dt3$Total <- NA
dt3$Order <- 3
dt3$Statistic <- "Row Pct"
names(dt3) <- gsub("rowpct.", "", names(dt3), fixed = TRUE)
}
# Transpose Col Percents
dt4 <- NULL
if (!option_true(options, "nocol", FALSE)) {
dt4 <- reshape(dt, timevar = "CAT2", idvar = "CAT1",
v.names = "colpct", direction = "wide",
drop = c("PCT", "rowcnt", "colcnt", "CNT", "rowpct"))
dt4$Total <- NA
dt4$Order <- 4
dt4$Statistic <- "Col Pct"
names(dt4) <- gsub("colpct.", "", names(dt4), fixed = TRUE)
}
#browser()
dt5 <- NULL
dt6 <- NULL
# Add row total if requested
if (option_true(options, "totrow", TRUE)) {
dt5 <- data.frame(CAT1 = "Total")
for (nm in names(lkp2)) {
dt5[[nm]] <- lkp2[[nm]]
}
dt5$Total = sum(lkp2, na.rm = TRUE)
dt5$Order = 1
dt5$Statistic = "Frequency"
if (!option_true(options, "nopercent", FALSE)) {
dt6 <- data.frame(CAT1 = "Total")
for (nm in names(lkp2)) {
dt6[[nm]] <- lkp2[[nm]] / sum(lkp2, na.rm = TRUE) * 100
}
dt6$Total = 100
dt6$Order = 2
dt6$Statistic = "Percent"
}
}
# Combine everthing
ret <- rbind(dt1, dt2, dt3, dt4,
make.row.names = FALSE,
stringsAsFactors = FALSE)
# Get all value column names
nnms <- names(ret)[!names(ret) %in% c("CAT1", "Order", "Statistic")]
# Sort data frame by category and order
ret <- ret[order(ret$CAT1, ret$Order), c("CAT1", "Statistic", nnms) ]
# Make sure total rows are at the end, after the sort
if (!is.null(dt5) & !is.null(dt6)) {
ret <- rbind(ret,
dt5[, c("CAT1", "Statistic", nnms)],
dt6[, c("CAT1", "Statistic", nnms)],
make.row.names = FALSE, stringsAsFactors = FALSE)
} else if (!is.null(dt5)) {
ret <- rbind(ret,
dt5[, c("CAT1", "Statistic", nnms)],
make.row.names = FALSE, stringsAsFactors = FALSE)
}
# Kill rownames
rownames(ret) <- NULL
# Rename to Category so output_report() will recognize as a stub
names(ret)[1] <- "CAT"
# Get format
fmt <- get_option(options, "format", "%.2f")
# Create formatting list
lst <- list(Frequency = "%d", Percent = fmt,
'Row Pct' = fmt, 'Col Pct' = fmt)
fl <- as.flist(lst, type = "row", lookup = ret$Statistic)
# Assign flist to data columns
fmts <- list()
for (nm in nnms) {
fmts[[nm]] <- fl
}
formats(ret) <- fmts
# Kill column total if requested
if (!option_true(options, "totcol", TRUE)) {
ret$Total <- NULL
}
# Assign label to Category
attr(ret$CAT, "label") <- lbl1
# Add spanning headers
if (!is.null(bylbl)) {
lbl <- paste0(bylbl, "Table of ", var1, " by ", var2)
} else {
lbl <- paste0("Table of ", var1, " by ", var2)
}
spn2 <- span(1, ncol(ret), label = lbl, level = 2)
spn1 <- span(3, ncol(ret), label = lbl2, level = 1)
attr(ret, "spans") <- list(spn1, spn2)
# Add footnote for missing values
if (!has_option(options, "missing")) {
fa <- attr(freqdata, "footnotes")
if (!is.null(fa)) {
attr(ret, "footnotes") <- fa
}
}
return(ret)
}
get_output_oneway <- function(data, tb, weight = NULL, options = NULL,
by = NULL, shape = "wide", stats = NULL,
order = "") {
# Get frequencies
ret <- freq_oneway(data = data, tb = tb, weight = weight,
options = options, stats = stats, out = TRUE,
order = order)
# Bind variable name
tmp <- list(VAR = tb)
df <- as.data.frame(tmp, stringsAsFactors = FALSE)
ret <- cbind(df, ret)
# Bind by variables
if (!is.null(by)) {
tmp <- list()
for(nm in names(by)) {
tmp[[nm]] <- by[nm]
}
df <- as.data.frame(tmp, stringsAsFactors = FALSE)
rownames(df) <- NULL
ret <- cbind(df, ret)
}
nms <- names(ret)
if (!is.null(shape)) {
if (shape == "long") {
ret <- proc_transpose(ret, copy = c(names(by), "VAR"),
id = "CAT", name = "STAT", log = FALSE)
} else if (all(shape == "stacked")) {
ret <- proc_transpose(ret, name = "STAT",
by = c(names(by), "VAR", "CAT"), log = FALSE)
rnms <- names(ret)
rnms[rnms %in% "COL1"] <- "VALUES"
names(ret) <- rnms
}
}
return(ret)
}
get_output_twoway <- function(data, tb1, tb2, weight, options, out = FALSE,
by = NULL, shape = "wide", stats = NULL, order = "") {
ret <- freq_twoway(data = data, tb1 = tb1, tb2 = tb2, weight = weight,
options = options, out = out, stats = stats, order = order)
# Bind variable names
tmp <- list(VAR1 = tb1, VAR2 = tb2)
df <- as.data.frame(tmp, stringsAsFactors = FALSE)
ret <- cbind(df, ret)
if (!is.null(by)) {
tmp <- list()
for(nm in names(by)) {
tmp[[nm]] <- by[nm]
}
df <- as.data.frame(tmp, stringsAsFactors = FALSE)
rownames(df) <- NULL
ret <- cbind(df, ret)
}
nms <- names(ret)
if (!is.null(shape)) {
if (shape == "long") {
ret <- proc_transpose(ret, id = c("CAT1", "CAT2"),
copy = c(names(by), "VAR1", "VAR2"),
name = "STAT", log = FALSE)
} else if (all(shape == "stacked")) {
ret <- proc_transpose(ret, name = "STAT",
by = c(names(by), "VAR1", "VAR2", "CAT1", "CAT2"),
log = FALSE)
rnms <- names(ret)
rnms[rnms %in% "COL1"] <- "VALUES"
names(ret) <- rnms
}
}
return(ret)
}
#' @import common
get_output_specs <- function(tbls, outs, opts, output) {
ret <- list()
sts <- c("n", "cnt", "pct", "cumsum", "cumpct")
if (length(outs) >= 1) {
for (nm in names(outs)) {
if ("out_req" %in% class(outs[[nm]])) {
if (outs[[nm]]$report %eq% TRUE) {
ret[[nm]] <- outs[[nm]]
} else if (is.null(outs[[nm]]$table)) {
ot <- outs[[nm]]
tnms <- names(tbls)
if (is.null(tnms))
tnms <- tbls
for (i in seq_len(length(tbls))) {
if (length(tbls) == 1) {
tnm <- nm
} else {
tnm <- tnms[[i]]
if (tnm == "")
tnm <- tbls[[i]]
}
ot$table <- tbls[[i]]
if (is.null(ot$shape))
ot$shape <- "wide"
ret[[tnm]] <- ot
}
} else {
ot <- outs[[nm]]
if (is.null(ot$shape))
ot$shape = "wide"
ret[[nm]] <- ot
}
} else {
warning("proc_freq: Unknown parameter '" %p% nm %p% "'")
}
}
} else {
tnms <- names(tbls)
if (is.null(tnms))
tnms <- tbls
for (i in seq_len(length(tbls))) {
nm <- tnms[[i]]
if (nm == "")
nm <- tbls[[i]]
if (option_true(output, "long", FALSE)) {
ret[[nm]] <- out_spec(table = tbls[[i]], stats = sts, shape = "long")
} else if (option_true(output, "stacked", FALSE)) {
ret[[nm]] <- out_spec(table = tbls[[i]], stats = sts, shape = "stacked")
} else {
ret[[nm]] <- out_spec(table = tbls[[i]], stats = sts, shape = "wide")
}
}
}
return(ret)
}
get_nlevels <- function(data, var1, var2 = NULL, byvars = NULL,
out = FALSE, missing = FALSE) {
ret <- NULL
vars <- c(var1)
l1miss <- NULL
l2miss <- NULL
if (missing) {
l1vals <- data[[var1]]
l1miss <- sum(any(is.na(data[[var1]])))
} else {
l1vals <- data[[var1]][!is.na(data[[var1]])]
}
lvls <- c(length(unique(l1vals)))
lbl <- ""
if (!is.null(var2)) {
if (missing) {
l2vals <- data[[var2]]
l2miss <- sum(any(is.na(data[[var2]])))
} else
l2vals <- data[[var2]][!is.na(data[[var2]])]
}
if (out) {
if (!is.null(var2)) {
if (missing) {
l2cnt <- length(unique(l2vals))
ret <- data.frame(VAR1 = lvls, VAR1.MISS = l1miss,
VAR1.NONMISS = lvls - l1miss,
VAR2 = l2cnt, VAR2.MISS = l2miss,
VAR2.NONMISS = l2cnt - l2miss,
stringsAsFactors = FALSE)
labels(ret) <- list(VAR1 = var1, VAR2 = var2,
VAR1.MISS = var1 %p% "Missing Levels",
VAR1.NONMISS = var1 %p% "Nonmissing Levels",
VAR2.MISS = var2 %p% "Missing Levels",
VAR2.NONMISS = var2 %p% "Nonmissing Levels"
)
} else {
ret <- data.frame(VAR1 = lvls, VAR2 = length(unique(l2vals)),
stringsAsFactors = FALSE)
labels(ret) <- list(VAR1 = var1, VAR2 = var2)
}
} else {
if (missing) {
ret <- data.frame(VAR = lvls, MISS = l1miss, NONMISS = lvls - l1miss,
stringsAsFactors = FALSE)
labels(ret) <- list(VAR = var1, MISS = "Missing Levels",
NONMISS = "Nonmissing Levels")
} else {
ret <- data.frame(VAR = lvls, stringsAsFactors = FALSE)
labels(ret) <- list(VAR = var1)
}
}
bv <- list()
if (!is.null(byvars)) {
if (length(byvars) == 1)
nms <- "BY"
else
nms <- paste0("BY", seq_len(length(byvars)))
for (i in seq_along(nms)) {
bv[[nms[[i]]]] <- byvars[[names(byvars)[[i]]]]
}
bret <- as.data.frame(bv, stringsAsFactors = FALSE)
labels(bret) <- names(byvars)
ret <- cbind(bret, ret)
lbl <- paste0(byvars, collapse = "")
}
} else {
if (!is.null(var2)) {
vars[2] <- var2
lvls[2] <- length(unique(l2vals))
}
if (!missing) {
ret <- data.frame(stub = vars, levels = lvls, stringsAsFactors = FALSE)
labels(ret) <- list(stub = "Variable", levels = "Levels")
} else {
if (!is.null(var2)) {
mcnt <- c(l1miss, l2miss)
nmcnt <- c(lvls[1] - l1miss, lvls[2] - l2miss)
} else {
mcnt <- l1miss
nmcnt <- lvls[1] - l1miss
}
ret <- data.frame(stub = vars, levels = lvls,
MISS = mcnt, NONMISS = nmcnt,
stringsAsFactors = FALSE)
labels(ret) <- list(stub = "Variable", levels = "Levels",
MISS = "Missing Levels",
NONMISS = "Nonmissing Levels")
}
lbl <- gsub(",", "", byvars, fixed = TRUE)
}
# Add spanning headers
if (!is.null(byvars)) {
spn2 <- span(1, ncol(ret), label = lbl, level = 1)
# spn1 <- span(1, ncol(ret), label = "Number of Variable Levels", level = 2)
attr(ret, "spans") <- list(spn2)
} else {
# lbl <- paste0("Table of ", var1, " by ", var2)
# spn2 <- span(1, ncol(ret), label = lbl, level = 2)
# #spn1 <- span(1, ncol(ret), label = "Number of Variable Levels", level = 1)
# attr(ret, "spans") <- list(spn1)
}
return(ret)
}
# Zero Fill -------------------------------------------------------------
# Appends missing combination to data frame and
# adds a variable __cnt by which you can count correctly.
get_nway_zero_fills <- function(data, outs, by = NULL, weight = NULL, options = NULL) {
if (option_true(options, "nosparse", FALSE) ) {
if (is.null(weight))
data[["__cnt"]] <- 1
else
data[["__cnt"]] <- data[[weight]]
ret <- data
} else {
# Get table variable vectors
if ("list" %in% class(outs))
ots <- get_output_tables(outs)
else
ots <- outs
# Split into vectors
tbls <- get_table_list(ots)
# Set count value on existing records
if (is.null(weight)) {
data[["__cnt"]] <- 1
} else {
data[["__cnt"]] <- data[[weight]]
}
ret <- data
for (i in seq_len(length(tbls))) {
tb <- tbls[[i]]
v1 <- list()
# Get unique values of target var
for (i in seq_len(length(tb))) {
if (is.factor(data[[tb[i]]])) {
v1[[tb[i]]] <- levels(data[[tb[i]]])
} else {
v1[[tb[i]]] <- names(sort(table(as.character(data[[tb[i]]]))))
}
}
# Get unique by values
if (!is.null(by)) {
for (i in seq_len(length(by))) {
if (is.factor(data[[by[i]]])) {
v1[[by[i]]] <- levels(data[[by[i]]])
} else {
v1[[by[i]]] <- names(sort(table(as.character(data[[by[i]]]))))
}
}
}
# Expand combinations
ex <- expand.grid(v1, stringsAsFactors = FALSE)
if (nrow(ex) > 0) {
# Zero fill combinations
ex[["__cnt"]] <- 0
# Merge combinations onto original data
ret <- merge(ret, ex, sort = FALSE, all = TRUE)
}
}
}
return(ret)
}
get_table_list <- function(tbls) {
ret <- NULL
if (!is.null(tbls)) {
ret <- strsplit(tbls, "*", fixed = TRUE)
for (i in seq_len(length(ret))) {
ret[[i]] <- trimws(ret[[i]])
}
}
return(ret)
}
get_output_tables <- function(outs) {
ret <- c()
if (!is.null(outs)) {
for (ot in outs) {
ret[length(ret) + 1] <- ot[["table"]]
}
}
return(ret)
}
# Drivers -----------------------------------------------------------------
#' @import fmtr
gen_report_freq <- function(data,
by = NULL,
tables = NULL,
options = NULL,
weight = NULL,
view = TRUE,
titles = NULL,
order = NULL,
plots = NULL) {
res <- list()
# print("Orig print_location")
# print(print_location)
# browser()
# Deal with sparse option
dta <- get_nway_zero_fills(data, tables, by, weight, options)
wgt <- "__cnt"
bylbls <- c()
if (!is.null(by)) {
lst <- unclass(dta)[by]
for (nm in names(lst))
lst[[nm]] <- as.factor(lst[[nm]])
dtlst <- split(dta, lst, sep = "|", drop = TRUE)
snms <- strsplit(names(dtlst), "|", fixed = TRUE)
for (k in seq_len(length(snms))) {
for (l in seq_len(length(by))) {
lv <- ""
if (!is.null(bylbls[k])) {
if (!is.na(bylbls[k])) {
lv <- bylbls[k]
}
}
bylbls[k] <- paste0(lv, by[l], "=", snms[[k]][l], ", ")
}
}
} else {
dtlst <- list(dta)
}
# Loop through by groups
for (j in seq_len(length(dtlst))) {
# Get table for this by group
dt <- dtlst[[j]]
# Loop through table requests
for (i in seq_len(length(tables))) {
nm <- names(tables)[i]
tb <- tables[i]
#browser()
#out <- i == length(tables) & has_option(options, "out")
crstab <- NULL
chisq <- NULL
fisher <- NULL
nlevels <- NULL
plotres <- NULL
# Split cross variables
splt <- trimws(strsplit(tb, "*", fixed = TRUE)[[1]])
# Perform either one-way or two-way frequency count
if (length(splt) == 1) {
# Assign new label if there are by groups
if (length(bylbls[j]) > 0) {
if (!is.null(attr(data[[tb]], "label")))
attr(dt[[tb]], "label") <- paste0(bylbls[j], attr(data[[tb]], "label"))
else
attr(dt[[tb]], "label") <- paste0(bylbls[j], tb)
}
# Deal with ordering
if (order == "data") {
dt[[tb]] <- factor(dt[[tb]], levels = unique(data[[tb]]))
} else if (order == "formatted") {
fmt1 <- formats(data)[[tb]]
if (!is.null(fmt1)) {
if ("fmt" %in% class(fmt1)) {
attr(fmt1, "as.factor") <- TRUE
dt[[tb]] <- fapply(dt[[tb]], fmt1)
}
}
}
# Perform one-way frequency
result <- freq_oneway(dt, tb, wgt, options, out = FALSE, order = order)
# Get nlevels if requested
if (has_option(options, "nlevels")) {
nlevels <- get_nlevels(dt, tb, byvars = bylbls[j],
missing = has_option(options, "missing"))
}
if (!is.null(plots)) {
plotres <- render_freqplot(result, tb, plt = plots[[i]])
}
} else if (length(splt) == 2) {
bylbl <- NULL
if (length(bylbls[j]) > 0) {
bylbl <- bylbls[j]
}
# Deal with ordering
if (order == "data") {
dt[[splt[1]]] <- factor(dt[[splt[1]]], levels = unique(data[[splt[1]]]))
dt[[splt[2]]] <- factor(dt[[splt[2]]], levels = unique(data[[splt[2]]]))
} else if (order == "formatted") {
fmt1 <- formats(data)[[splt[1]]]
if (!is.null(fmt1)) {
if ("fmt" %in% class(fmt1)) {
attr(fmt1, "as.factor") <- TRUE
dt[[splt[1]]] <- fapply(dt[[splt[1]]], fmt1)
}
}
fmt2 <- formats(data)[[splt[2]]]
if (!is.null(fmt2)) {
if ("fmt" %in% class(fmt2)) {
attr(fmt2, "as.factor") <- TRUE
dt[[splt[2]]] <- fapply(dt[[splt[2]]], fmt2)
}
}
}
# Perform two-way frequency
result <- freq_twoway(dt, splt[1], splt[2], wgt, options,
out = FALSE, order = order)
if (!has_option(options, "list")) {
# Perform cross tab by default
crstab <- cross_tab(result, options, splt[1], splt[2], bylbl)
}
if (get_option(options, "fisher", FALSE)) {
if (!is.null(wgt))
fisher <- get_fisher(dt[[splt[1]]], dt[[splt[[2]]]], dt[[wgt]],
bylbl = bylbls[j])
else
fisher <- get_fisher(dt[[splt[1]]], dt[[splt[[2]]]],
bylbl = bylbls[j])
}
if (get_option(options, "chisq", FALSE)) {
if (!is.null(wgt))
chisq <- get_chisq(dt[[splt[1]]], dt[[splt[[2]]]], dt[[wgt]],
bylbl = bylbls[j])
else
chisq <- get_chisq(dt[[splt[1]]], dt[[splt[[2]]]], bylbl = bylbls[j])
}
# Get nlevels if requested
if (has_option(options, "nlevels")) {
nlevels <- get_nlevels(dt, splt[1], splt[2], byvars = bylbls[j],
missing = has_option(options, "missing"))
}
if (!is.null(plots)) {
plotres <- render_freqplot(result, splt[1], splt[2], plots[[i]])
}
} else {
stop("Procedure does not yet support n-way frequencies.")
}
# Cast to tibble if incoming data was a tibble
if ("tbl_df" %in% class(data)) {
if (!is.null(crstab))
crstab <- as_tibble(crstab)
if (!is.null(result))
result <- as_tibble(result)
if (!is.null(fisher))
fisher <- as_tibble(fisher)
if (!is.null(chisq))
chisq <- as_tibble(chisq)
if (!is.null(nlevels))
nlevels <- as_tibble(nlevels)
}
if (!is.null(nlevels)) {
res[[paste0("Nlevels:", get_name(nm, tb, bylbls[j]))]] <- nlevels
}
# If a cross tab was produced, add it to result
if (!is.null(crstab)) {
res[[get_name(nm, tb, bylbls[j])]] <- crstab
# if ("out" %in% names(options) & i == length(tables)) {
#
# res[[get_name(options[["out"]], "", bylbls[j])]] <- result
# }
} else { # Otherwise add list to result
res[[get_name(nm, tb, bylbls[j])]] <- result
}
if (!is.null(chisq)) {
res[[get_name("Chisq", tb, bylbls[j])]] <- chisq
}
if (!is.null(fisher)) {
res[[get_name("Fisher", tb, bylbls[j])]] <- fisher
}
if (!is.null(plots)) {
res[[get_name("Plots", tb, bylbls[j], addvar = TRUE)]] <- plotres
}
}
}
gv <- options("procs.print")[[1]]
if (is.null(gv))
gv <- TRUE
# Create viewer report if requested
if (gv) {
if (view == TRUE && interactive()) {
vrfl <- tempfile()
if (is.null(titles)) {
titles <- "The FREQ Function"
}
out <- output_report(res, dir_name = dirname(vrfl),
file_name = basename(vrfl), out_type = "HTML",
titles = titles, margins = .5, viewer = TRUE)
show_viewer(out)
}
}
return(res)
}
gen_output_freq <- function(data,
by = NULL,
tables = NULL,
options = NULL,
weight = NULL,
output = NULL,
order = NULL,
rename = NULL,
keep = NULL,
drop = NULL) {
# Deal with sparse option
dta <- get_nway_zero_fills(data, output, by, weight, options)
wgt <- "__cnt"
byvals <- list()
bynms <- NULL
if (!is.null(by)) {
if (length(by) == 1)
bynms <- "BY"
else
bynms <- paste0("BY", seq(1, length(by)))
bylbls <- setNames(by, bynms)
lst <- unclass(dta)[by]
for (nm in names(lst))
lst[[nm]] <- as.factor(lst[[nm]])
dtlst <- split(dta, lst, sep = "|")
snms <- strsplit(names(dtlst), "|", fixed = TRUE)
for (k in seq_len(length(snms))) {
byvals[[k]] <- snms[[k]]
names(byvals[[k]]) <- bynms
}
} else {
dtlst <- list(dta)
}
res <- list()
if (length(output) > 0) {
for (nm in names(output)) {
# print("Orig print_location")
# print(print_location)
# browser()
outp <- output[[nm]]
tb <- outp$table
tmpres <- NULL
chisq <- NULL
fisher <- NULL
nlevels <- NULL
# Loop through by groups
for (j in seq_len(length(dtlst))) {
# Get table for this by group
dt <- dtlst[[j]]
if (nrow(dt) > 0 || has_option(options, "nosparse") == FALSE) {
crstab <- NULL
tmpchisq <- NULL
tmpfisher <- NULL
tmpnlevels <- NULL
# Split cross variables
splt <- trimws(strsplit(tb, "*", fixed = TRUE)[[1]])
# Perform either one-way or two-way frequency count
if (length(splt) == 1) {
# Deal with ordering
if (order == "data") {
dt[[tb]] <- factor(dt[[tb]], levels = unique(data[[tb]]))
} else if (order == "formatted") {
fmt1 <- formats(data)[[tb]]
if (!is.null(fmt1)) {
if ("fmt" %in% class(fmt1)) {
attr(fmt1, "as.factor") <- TRUE
dt[[tb]] <- fapply(dt[[tb]], fmt1)
}
}
}
if (length(byvals) >= j) {
result <- get_output_oneway(dt, tb, wgt, options,
byvals[[j]], shape = outp$shape,
stats = outp$stats, order = order)
} else {
result <- get_output_oneway(dt, tb, wgt, options,
NULL, shape = outp$shape,
stats = outp$stats, order = order)
}
if (has_option(options, "nlevels")) {
if (length(byvals) >= j) {
tmpnlevels <- get_nlevels(dt, tb, byvars = byvals[[j]], out = TRUE,
missing = has_option(options, "missing"))
} else {
tmpnlevels <- get_nlevels(dt, tb, byvars = NULL, out = TRUE,
missing = has_option(options, "missing"))
}
}
} else if (length(splt) == 2) {
# Deal with ordering
if (order == "data") {
dt[[splt[1]]] <- factor(dt[[splt[1]]], levels = unique(data[[splt[1]]]))
dt[[splt[2]]] <- factor(dt[[splt[2]]], levels = unique(data[[splt[2]]]))
} else if (order == "formatted") {
fmt1 <- formats(data)[[splt[1]]]
if (!is.null(fmt1)) {
if ("fmt" %in% class(fmt1)) {
attr(fmt1, "as.factor") <- TRUE
dt[[splt[1]]] <- fapply(dt[[splt[1]]], fmt1)
}
}
fmt2 <- formats(data)[[splt[2]]]
if (!is.null(fmt2)) {
if ("fmt" %in% class(fmt2)) {
attr(fmt2, "as.factor") <- TRUE
dt[[splt[2]]] <- fapply(dt[[splt[2]]], fmt2)
}
}
}
if (has_option(options, "crosstab")) {
result <- freq_twoway(dt, splt[1], splt[2], wgt, options,
out = FALSE, order = order)
result <- cross_tab(result, options, splt[1], splt[2], "")
} else {
# Perform two-way frequency
if (length(byvals) >= j) {
result <- get_output_twoway(dt, splt[1], splt[2], wgt, options,
byvals[[j]], shape = outp$shape,
out = TRUE, stats = outp$stats, order = order)
} else {
result <- get_output_twoway(dt, splt[1], splt[2], wgt, options,
NULL, shape = outp$shape,
out = TRUE, stats = outp$stats, order = order)
}
}
if (has_option(options, "nlevels")) {
if (length(byvals) >= j) {
tmpnlevels <- get_nlevels(dt, splt[1], splt[2],
byvars = byvals[[j]], out = TRUE,
missing = has_option(options, "missing"))
} else {
tmpnlevels <- get_nlevels(dt, splt[1], splt[2],
byvars = NULL, out = TRUE,
missing = has_option(options, "missing"))
}
}
if (!is.null(outp$stats)) {
if (option_true(options, "fisher", FALSE)) {
if (!is.null(wgt))
tmpfisher <- get_fisher(dt[[splt[1]]], dt[[splt[[2]]]], dt[[wgt]],
bylbl = byvals[j], output = TRUE)
else
tmpfisher <- get_fisher(dt[[splt[1]]], dt[[splt[[2]]]],
bylbl = byvals[j], output = TRUE)
if (is.null(fisher))
fisher <- tmpfisher
else
fisher <- rbind(fisher, tmpfisher)
}
if (option_true(options, "chisq", FALSE)) {
if (!is.null(wgt))
tmpchisq <- get_chisq(dt[[splt[1]]], dt[[splt[[2]]]], dt[[wgt]],
bylbl = byvals[j], output = TRUE)
else
tmpchisq <- get_chisq(dt[[splt[1]]], dt[[splt[[2]]]],
bylbl = byvals[j], output = TRUE)
if (is.null(chisq))
chisq <- tmpchisq
else
chisq <- rbind(chisq, tmpchisq)
}
}
} else {
stop("Procedure does not yet support n-way frequencies.")
}
# Cast to tibble if incoming data was a tibble
if ("tbl_df" %in% class(data)) {
if (!is.null(result))
result <- as_tibble(result)
if (!is.null(chisq))
chisq <- as_tibble(chisq)
if (!is.null(fisher))
fisher <- as_tibble(fisher)
if (!is.null(nlevels))
nlevels <- as_tibble(nlevels)
}
if (has_option(options, "nlevels")) {
if (is.null(nlevels))
nlevels <- tmpnlevels
else
nlevels <- rbind(nlevels, tmpnlevels)
}
if (!is.null(tmpres))
tmpres <- rbind(tmpres, result)
else
tmpres <- result
}
}
if (!is.null(by)) {
tmpres <- restore_datatypes(tmpres, data, by, bynms)
labels(tmpres) <- bylbls
}
# System Labels
#labels(tmpres) <- append(mlbls, bylbls)
# User labels
if (!is.null(outp$label))
labels(tmpres) <- outp$label
# Formats
if (!is.null(outp$format))
formats(tmpres) <- outp$format
# Assign to output
if (!is.null(has_option(options, "nlevels")))
res[[paste0("NLevels:", nm)]] <- nlevels
if (!has_option(options, "notable")) {
# Select the rename/keep/drop vector that aligns with this table request
tidx <- match(nm, names(output))
trename <- get_table_vector(rename, nm, tidx)
tkeep <- get_table_vector(keep, nm, tidx)
tdrop <- get_table_vector(drop, nm, tidx)
# Perform rename operation
tmpres <- rename_data(tmpres, trename)
# Perform keep operation
tmpres <- keep_data(tmpres, tkeep)
# Perform drop operation
tmpres <- drop_data(tmpres, tdrop)
res[[nm]] <- tmpres
}
if (!is.null(chisq)) {
if (!is.null(by))
labels(chisq) <- bylbls
res[[paste0("chisq:", nm)]] <- chisq
}
if (!is.null(fisher)) {
if (!is.null(by))
labels(fisher) <- bylbls
res[[paste0("fisher:", nm)]] <- fisher
}
}
}
# Rename CAT/BY columns to original variable names from labels
if (has_option(options, "varnames")) {
for (nm in names(res)) {
df <- res[[nm]]
if (is.data.frame(df)) {
nms <- names(df)
for (i in seq_along(nms)) {
if (grepl("^(CAT|BY)\\d*$", nms[i])) {
lbl <- attr(df[[nms[i]]], "label")
if (!is.null(lbl)) {
nms[i] <- lbl
}
}
}
names(res[[nm]]) <- nms
}
}
}
return(res)
}
# Plots -------------------------------------------------------------------
Try the procs package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.