.onLoad <- function(libname, pkgname) {
op <- options()
op.itemNaming <- list(
attribute_column_prefix = '_',
special_column_prefix = '__',
includes_column_name = 'includes'
)
toset <- !(names(op.itemNaming) %in% names(op))
if(any(toset)) options(op.itemNaming[toset])
invisible()
}
#' Generic formatting function. It is the most generic call of the library itemNaming.
#'
#' @param item_numeral Object that knows how to write in a natural language a numeral with a noun. By default it uses an English numeral with the noun "item" (that is capable of creating strings "1 item" or "15 items")
#' @param all_except_infix_fn Function that can create a description of complementary notation in a natural language. The arguments are described later. Default function writes in English text "all items except for", using the \code{item_numeral} for the word "items".
#' @param threshold_for_inversion Number between 0 and 1 that describes the threshold of percentage of selected items to trigger a complementary notation.
#' @param included_column_name Name of the column that contains filtered cases to display. Essential to make the complementary notation possible. Defaults to \code{"__included"}.
#' @param item_ellipsis_fn Function that can create an ellipsis notation in the middle of a long list. Defaults to a function that displays text ", 13 items more, " (assuming the item_numeral is for the noun "item").
#' @param max_explicit_items_count Maximal number of items to be ever displayed in comma separated list. Ellipsis notation will be used, if number of items exceed this value.
#' @param number_of_elements_around_ellipsis Number of elements around the actual ellipsis, when the ellipsis is used. Must be a two element integer vector. Defaults to \code{c(3,2)} to produce text like "item1, item2, item3, 5 items more, item9 and item10"
#' @param txt_separator String that separates list elements for all but last item. Defaults to ", ".
#' @param txt_spearator_last String that separates two last list elements. Defaults to "\\uA0and ". \\uA0 is a unicode for non-breakable space.
#' @param txt_attribute_separator Simmilar to \code{txt_separator}, but for the attributes of a single item (if there are any). Defaults to ", ".
#' @param txt_attribute_separator_last Simmilar to \code{txt_separator_last}, but for the attributes of a single item (if there are any). Defaults to "\\uA0and ".
#' @param txt_attribute_prefix String that gets pasted at the beginning of the attribute list. Defaults to "\\ua0(".
#' @param txt_attribute_suffix String that gets pasted at the beginning of the attribute list. Defaults to ")".
#' @param txt_attribute_bare_quote If the attribute name is available only in its internal name (its label is not specified), this string will get pasted before and after. Defaults to markdown code "`". This may be extended in future to allow formatting in different markup languages, which don't use symmetric quotes, like LaTeX (\code{"\\verbatim\{"} and \\code{"\}"}).
#' @param txt_attribute_label_quote The same as \code{txt_attribute_bare_quote} but for labelled attributes. Defaults to empty string.
#' @param txt_attribute_infix The string that will be inserted between the attribute name and its value. Defaults to ":\\uA0".
#'
#' @return A closure that turns a data.frame into a formatted list (as string)
#' @export
generic_df_formatter_gen<-function(item_numeral=English_numeral$new(singular='item', plural='items', number_format_fn=format_integer, flag_skip_one = FALSE),
all_except_infix_fn=all_except_infix_fn_en, threshold_for_inversion=0.8, included_column_name='__included',
item_ellipsis_fn=item_ellipsis_fn_en, max_explicit_items_count=7, number_of_elements_around_ellipsis=c(3,2),
txt_separator=', ', txt_separator_last = '\uA0and ',
txt_attribute_separator=', ', txt_attribute_separator_last='\uA0and ', txt_attribute_prefix='\uA0(', txt_attribute_suffix=')',
txt_attribute_bare_quote = '`', txt_attribute_label_quote = '', txt_attribute_infix = ':\uA0'
) {
step_4_display_item<-step_4_display_item_gen(txt_attribute_separator=txt_attribute_separator, txt_attribute_separator_last=txt_attribute_separator_last,
txt_attribute_prefix=txt_attribute_prefix, txt_attribute_suffix=txt_attribute_suffix,
txt_attribute_bare_quote = txt_attribute_bare_quote, txt_attribute_label_quote = txt_attribute_label_quote,
txt_attribute_infix = txt_attribute_infix, step_5_display_element=step_5_display_single_item)
step_3_comma<-step_3_comma_gen(txt_separator=txt_separator, txt_separator_last = txt_separator_last, display_item_fn=step_4_display_item)
step_2_ellipsis<-step_2_ellipsis_gen(item_ellipsis=item_ellipsis_fn,
max_explicit_items_count=max_explicit_items_count, number_of_elements_around_ellipsis=number_of_elements_around_ellipsis,
step_3_comma)
gen_fn<-function(items_df) {
out<-step_1_inversion(items_df=items_df, all_except_infix = all_except_infix_fn, item_numeral=item_numeral,
threshold_for_inversion=threshold_for_inversion, step_2_ellipsis, included_column_name=included_column_name)
return(out)
}
return(gen_fn)
}
#' Formatter customized for quoting variables.
#'
#' Parameters are the same as for \code{\link{generic_df_formatter_gen}}, only the default values are slightliy different.
#' The real difference is in the closure returned: it accepts two arguments: \code{varnames} and \code{df}
#' @inherit generic_df_formatter_gen
#' @export
variable_list_formatter_gen<-function(variable_numeral=English_numeral$new(singular='variable', plural='variables', flag_skip_one=FALSE),
flag_include_raw_name=TRUE,
all_except_infix_fn=all_exept_infix_fn_en, threshold_for_inversion=0.8,
item_ellipsis_fn=item_ellipsis_fn_en, max_explicit_items_count=7, number_of_elements_around_ellipsis=c(3,2),
txt_separator=', ', txt_separator_last = ' and ',
txt_attribute_separator=', ', txt_attribute_separator_last=' and ', txt_attribute_prefix=' (', txt_attribute_suffix=')',
txt_attribute_bare_quote = '`', txt_attribute_label_quote = '', txt_attribute_infix = ':\uA0') {
inner_gen<-generic_df_formatter_gen(item_numeral=variable_numeral,
all_except_infix_fn=all_except_infix_fn, threshold_for_inversion=threshold_for_inversion, included_column_name='__included',
item_ellipsis_fn=item_ellipsis_fn, max_explicit_items_count=max_explicit_items_count, number_of_elements_around_ellipsis=number_of_elements_around_ellipsis,
txt_separator=txt_separator, txt_separator_last = txt_separator_last,
txt_attribute_separator=txt_attribute_separator, txt_attribute_separator_last=txt_attribute_separator_last,
txt_attribute_prefix=txt_attribute_prefix, txt_attribute_suffix=txt_attribute_suffix,
txt_attribute_bare_quote = txt_attribute_bare_quote, txt_attribute_label_quote = txt_attribute_label_quote,
txt_attribute_infix = txt_attribute_infix)
out_gen<-function(varnames, df) {
checkmate::assert_character(varnames)
checkmate::assert_data_frame(df)
varlabels<-
Hmisc::label(df)
properties=purrr::map(seq_along(varlabels), ~list(label=varlabels[[.]]))
rawnames<-colnames(df)
rawnames[varlabels=='']<-NA
items_df<-data.table::data.table(var=colnames, '_var'=properties, rawnames=rawnames, '__included'=colnames(df) %in% varnames)
attr(items_df$rawnames, 'label')<-'Field name'
inner_gen(items_df)
}
return(out_gen)
}
#' @describeIn variable_list_formatter_gen Formatter customized for quoting variables that include data.frame in the closure.
#' @export
variable_list_formatter_df_gen<-function(df, variable_numeral=English_numeral$new(singular='variable', plural='variables', flag_skip_one=FALSE),
flag_include_raw_name=TRUE,
all_except_infix_fn=all_except_infix_fn_en, threshold_for_inversion=0.8,
item_ellipsis_fn=item_ellipsis_fn_en, max_explicit_items_count=7, number_of_elements_around_ellipsis=c(3,2),
txt_separator=', ', txt_separator_last = ' and ',
txt_attribute_separator=', ', txt_attribute_separator_last=' and ', txt_attribute_prefix=' (', txt_attribute_suffix=')',
txt_attribute_bare_quote = '`', txt_attribute_label_quote = '', txt_attribute_infix = ':\uA0') {
inner_gen<-generic_df_formatter_gen(item_numeral=variable_numeral,
all_except_infix_fn=all_except_infix_fn, threshold_for_inversion=threshold_for_inversion, included_column_name='__included',
item_ellipsis_fn=item_ellipsis_fn, max_explicit_items_count=max_explicit_items_count, number_of_elements_around_ellipsis=number_of_elements_around_ellipsis,
txt_separator=txt_separator, txt_separator_last = txt_separator_last,
txt_attribute_separator=txt_attribute_separator, txt_attribute_separator_last=txt_attribute_separator_last,
txt_attribute_prefix=txt_attribute_prefix, txt_attribute_suffix=txt_attribute_suffix,
txt_attribute_bare_quote = txt_attribute_bare_quote, txt_attribute_label_quote = txt_attribute_label_quote,
txt_attribute_infix = txt_attribute_infix)
varlabels<-Hmisc::label(df)
varlabels_attr<-varlabels
rawnames<-colnames(df)
rawnames_attr<-rawnames
filter<-varlabels==rawnames
varlabels[filter]<-NA
rawnames_attr[filter]<-NA
rawnames_attr[varlabels=='']<-NA
properties=purrr::map(seq_along(varlabels), ~list(label=varlabels_attr[[.]]))
items_df<-data.table::data.table(var=rawnames, '_var'=properties, rawnames=rawnames_attr)
attr(items_df$rawnames, 'label')<-'Field name'
out_gen<-function(varnames) {
data.table::set(items_df, NULL, '__included', rawnames %in% varnames)
inner_gen(items_df)
}
rm(filter, varlabels_attr, rawnames_attr)
rm(properties)
rm(varlabels)
return(out_gen)
}
#' Formatter customized for cases in the data.frame.
#'
#' Parameters are the same as for \code{\link{generic_df_formatter_gen}}, only the default values are slightliy different.
#' The real difference is in the closure returned: it accepts casenames (either string or integers). The formatter outputs all variables
#' encountered in the data.frame, so remove all unwanted variables before supply the data.frame.
#'
#' @inherit generic_df_formatter_gen
#' @export
case_list_formatter_df_gen<-function(df, case_name_var=NULL, case_names=NULL, attr_rows=character(0), variable_numeral=English_numeral$new(singular='case', plural='cases', flag_skip_one=FALSE),
flag_include_raw_name=TRUE,
all_except_infix_fn=all_except_infix_fn_en, threshold_for_inversion=0.8,
item_ellipsis_fn=item_ellipsis_fn_en, max_explicit_items_count=7, number_of_elements_around_ellipsis=c(3,2),
txt_separator=', ', txt_separator_last = ' and ',
txt_attribute_separator=', ', txt_attribute_separator_last=' and ', txt_attribute_prefix=' (', txt_attribute_suffix=')',
txt_attribute_bare_quote = '`', txt_attribute_label_quote = '', txt_attribute_infix = ':\uA0') {
inner_gen<-generic_df_formatter_gen(item_numeral=variable_numeral,
all_except_infix_fn=all_except_infix_fn, threshold_for_inversion=threshold_for_inversion, included_column_name='__included',
item_ellipsis_fn=item_ellipsis_fn, max_explicit_items_count=max_explicit_items_count, number_of_elements_around_ellipsis=number_of_elements_around_ellipsis,
txt_separator=txt_separator, txt_separator_last = txt_separator_last,
txt_attribute_separator=txt_attribute_separator, txt_attribute_separator_last=txt_attribute_separator_last,
txt_attribute_prefix=txt_attribute_prefix, txt_attribute_suffix=txt_attribute_suffix,
txt_attribute_bare_quote = txt_attribute_bare_quote, txt_attribute_label_quote = txt_attribute_label_quote,
txt_attribute_infix = txt_attribute_infix)
if(!is.null(case_name_var)) {
checkmate::assert_string(case_name_var)
if(!is.null(case_names)) {
stop("Cannot take both case_name_var and case_names arguments.")
}
if(!case_name_var %in% colnames(df)){
browser()
}
case_names<-df[[case_name_var]]
} else if(!is.null(case_names)) {
checkmate::assert_character(case_names, unique = TRUE)
if(length(case_names)!=nrow(df)) {
stop("case_names must have the same length as number of rows in df")
}
} else {
case_names<-case.names(df)
}
items_df<-data.table::data.table(cases=case_names)
attr_rows<-attr_rows[colnames(df) %in% attr_rows]
if(length(attr_rows)>0) {
#Adding other columns as custom attributes
data.table::set(items_df,NULL, data.table:::subset.data.table(df, NULL, attr_rows))
}
out_gen<-function(casenames) {
if(is.numeric(casenames)) {
data.table::set(items_df, NULL, '__included', seq_len(nrow(df)) %in% casenames)
} else {
data.table::set(items_df, NULL, '__included', case_names %in% casenames)
}
inner_gen(items_df)
}
rm(attr_rows)
return(out_gen)
}
#' Formatter customized for quoting elements from (e.g. character) vector.
#'
#' Parameters are the same as for \code{\link{generic_df_formatter_gen}} except it doesn't support the complementary format.
#'
#' @return Closure that takes a vector and produces a formatted string.
#'
#'
#' @inherit generic_df_formatter_gen
#' @export
vector_formatter_df_gen<-function(variable_numeral=English_numeral$new(singular='element', plural='elements', flag_skip_one=FALSE),
item_ellipsis_fn=item_ellipsis_fn_en, max_explicit_items_count=9, number_of_elements_around_ellipsis=c(4,3),
txt_separator=', ', txt_separator_last = ' and ',
txt_attribute_separator=', ', txt_attribute_separator_last=' and ', txt_attribute_prefix=' (', txt_attribute_suffix=')',
txt_attribute_bare_quote = '`', txt_attribute_label_quote = '', txt_attribute_infix = ':\uA0') {
inner_gen<-generic_df_formatter_gen(item_numeral=variable_numeral,
item_ellipsis_fn=item_ellipsis_fn, max_explicit_items_count=max_explicit_items_count, number_of_elements_around_ellipsis=number_of_elements_around_ellipsis,
txt_separator=txt_separator, txt_separator_last = txt_separator_last,
txt_attribute_separator=txt_attribute_separator, txt_attribute_separator_last=txt_attribute_separator_last,
txt_attribute_prefix=txt_attribute_prefix, txt_attribute_suffix=txt_attribute_suffix,
txt_attribute_bare_quote = txt_attribute_bare_quote, txt_attribute_label_quote = txt_attribute_label_quote,
txt_attribute_infix = txt_attribute_infix)
out_gen<-function(vector) {
items_df<-data.table::data.table(items=vector)
attr(items_df$items, 'label')<-variable_numeral$render_noun(1)
out<-inner_gen(items_df)
return(out)
}
return(out_gen)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.