[numfmt] preview formats using ooxml_format()

[JanMarvin]

This is the result of me wasting 20€ on ChatGPT Pro and ... doing a lot of it on my own either way while I was wasting an otherwise perfectly fine Sunday. I'll probably clean this up and add it to the package sometime soon. Among having this, to debug numfmts, this will allow us to improve the auto size calculation.

It is not perfect in every preview (e.g. with the last one, the actual format should be something like (€ 1,234.56) and not € (1,234.56), but at least the width of the string is identical.

analyze_number_format <- function(fmt) {
  # Regex to extract the currency/locale pattern
  currency_match <- regexpr("\\[\\$.*?\\-.*?\\]", fmt)
  currency_locale <- ifelse(currency_match > 0, regmatches(fmt, currency_match), NA)
  
  # Extract color codes if present
  colors <- c("Black", "Green", "White", "Blue", "Magenta", "Yellow", "Cyan", "Red")
  colors <- colors[which(sapply(sprintf("\\[%s\\]", colors), grepl, fmt))]
  if (length(colors)) {
    cls <- sprintf("\\[%s\\]", colors)
    cls <- ifelse(grepl(paste0(cls, "-"), fmt), paste0(cls, "-"), cls)
    
    fmt <- gsub(cls, "", fmt)
    
    # color_match <- gregexpr(cls, fmt)
    #
    # colors <- regmatches(fmt, color_match)[[1]]
    # colors <- colors[!grepl("\\[\\$.*?\\-.*?\\]", colors)]  # Exclude currency-related brackets
  } else {
    colors <- NA
  }
  
  # Parse currency and locale
  if (!is.na(currency_locale)) {
    currency_locale <- gsub("\\[|\\]", "", currency_locale)  # Remove brackets
    parts <- strsplit(currency_locale, "-")[[1]]  # Split currency and locale
    currency <- gsub("\\$", "", parts[1])  # Remove the $ sign
    locale <- parts[2]
  } else {
    currency <- NA
    locale <- NA
  }
  
  # Check if there is a # before or after the currency
  is_currency_at_back <- grepl("[#0?].*\\[\\$.*?\\]", fmt)
  
  is_pct <- FALSE
  if (grepl("%", fmt)) is_pct <- TRUE
  
  # Return results
  return(list(
    currency = currency,
    locale = locale,
    colors = colors,
    is_currency_at_back = is_currency_at_back,
    is_pct = is_pct
  ))
}

replace_after_underscore <- function(fmt) {
  # Replace everything following an underscore with a single space
  fmt <- gsub("_.", " ", fmt)  # Replace underscore and any character that follows it
  return(fmt)
}

# Helper functions for specific formatting tasks
add_big_mark <- function(number_str, big_mark = ",") {
  reversed <- strsplit(number_str, NULL)[[1]]
  reversed <- rev(reversed)
  grouped <- paste0(rev(reversed), collapse = "")
  grouped <- gsub("(?<=\\d)(?=(\\d{3})+$)", big_mark, grouped, perl = TRUE)
  return(grouped)
}

count_trailing_commas <- function(numfmt_string) {
  # Regular expression to match trailing commas followed only by '.' or the end of the string
  matches <- gregexpr(",+$", numfmt_string, perl = TRUE)
  
  # Check if the matches exist and only count if it meets the trailing condition
  if (matches[[1]][1] != -1) {
    trailing_section <- regmatches(numfmt_string, matches)[[1]]
    if (grepl(",+$", trailing_section)) {
      return(nchar(trailing_section))
    }
  }
  
  return(0)
}

format_number <- function(value, format_code) {
  
  is_accounting <- FALSE
  if (startsWith(format_code, "(") && endsWith(format_code, ")")) {
    is_accounting <- TRUE
    format_code <- substr(format_code, 2, nchar(format_code) - 1)
  }
  
  # Split format code into integer and fractional parts
  parts <- strsplit(format_code, "\\.")[[1]]
  integer_part <- parts[1]
  fractional_part <- ifelse(length(parts) > 1, parts[2], "")
  
  # Handle big marks (thousands separator)
  use_big_mark <- grepl(",", integer_part)
  integer_part <- gsub(",", "", integer_part)  # Remove commas for processing
  
  # Handle trailing big marks (divide input by 1000 for each trailing ",")
  trailing_commas <- count_trailing_commas(format_code)
  if (trailing_commas) {
    value <- value / (1000 ^ trailing_commas)
  }
  
  # Determine mandatory and optional digits
  mandatory_digits <- nchar(gsub("[^0]", "", integer_part))
  optional_digits <- nchar(gsub("[^#]", "", integer_part))
  
  # Round value based on the fractional part
  fractional_digits <- nchar(fractional_part)
  rounded_value <- if (fractional_digits > 0) {
    round(value, fractional_digits)
  } else {
    round(value)
  }
  
  # Process integer part
  integer_value <- trunc(abs(rounded_value))
  formatted_integer <- sprintf(paste0("%0", mandatory_digits, "d"), integer_value)
  
  if (use_big_mark) {
    if (grepl("^0", formatted_integer))
      formatted_integer <- add_big_mark(formatted_integer)
    else
      formatted_integer <- format(as.numeric(formatted_integer), big.mark = ",", scientific = FALSE)
  }
  
  # Handle fractional part if specified
  if (fractional_digits > 0) {
    fractional_value <- abs(rounded_value - trunc(rounded_value))
    formatted_fraction <- sprintf(paste0("%.", fractional_digits, "f"), fractional_value)
    formatted_fraction <- sub("^0\\.", "", formatted_fraction)  # Remove leading zero
    formatted_value <- paste0(formatted_integer, ".", formatted_fraction)
  } else {
    formatted_value <- formatted_integer
  }
  
  # Add negative sign or parentheses for negative numbers
  if (value < 0) {
    if (is_accounting) {
      formatted_value <- paste0("(", formatted_value, ")")
    } else {
      formatted_value <- paste0("-", formatted_value)
    }
  }
  
  return(formatted_value)
}

format_date <- function(value, format_code) {
  # Convert to Date object if not already
  if (inherits(value, "character") && grepl("\\d{4}-\\d{2}-\\d{2}", value)) {
    value <- as.Date(substr(value, 1, 10)) # Extract date part only
  } else if (!inherits(value, "Date")) {
    stop("Value is not a valid date format.")
  }
  
  # Extract components of the date
  year <- as.character(format(value, "%Y"))
  month <- as.character(as.numeric(format(value, "%m"))) # Non-padded month
  month_padded <- format(value, "%m") # Padded month
  day <- as.character(as.numeric(format(value, "%d"))) # Non-padded day
  day_padded <- format(value, "%d") # Padded day
  
  # Replace placeholders manually
  format_code <- gsub("yyyy", year, format_code)
  format_code <- gsub("yy", substr(year, 3, 4), format_code)
  format_code <- gsub("mmmmm", substr(months(value), 1, 1), format_code)
  format_code <- gsub("mmmm", months(value), format_code)
  format_code <- gsub("mmm", substr(months(value), 1, 3), format_code)
  format_code <- gsub("mm", month_padded, format_code)
  format_code <- gsub("\\bm\\b", month, format_code, perl = TRUE)
  format_code <- gsub("dd", day_padded, format_code)
  format_code <- gsub("\\bd\\b", day, format_code, perl = TRUE)
  
  return(format_code)
}

format_time <- function(value, format_code) {
  # Ensure value is POSIXct for time handling
  if (inherits(value, "character") && grepl("\\d{4}-\\d{2}-\\d{2}T\\d{2}:\\d{2}:\\d{2}", value)) {
    value <- as.POSIXct(value, format = "%Y-%m-%dT%H:%M:%S")
  } else if (!inherits(value, "POSIXct")) {
    return(format_code) # Skip time formatting if not a valid time format
  }
  
  # Extract time components
  hour <- format(value, "%H")
  hour_12 <- format(value, "%I")
  minute <- format(value, "%M")
  second <- format(value, "%S")
  am_pm <- format(value, "%p")
  
  # Replace placeholders manually
  format_code <- gsub("hh", hour_12, format_code)
  format_code <- gsub("h", as.numeric(hour_12), format_code)
  format_code <- gsub("HH", hour, format_code)
  format_code <- gsub("H", as.numeric(hour), format_code)
  format_code <- gsub("mm", minute, format_code)
  format_code <- gsub("ss", second, format_code)
  format_code <- gsub("AM/PM", am_pm, format_code, ignore.case = TRUE)
  
  return(format_code)
}

format_combined <- function(value, format_code) {
  # Handle both date and time components
  if (inherits(value, "character") && grepl("\\d{4}-\\d{2}-\\d{2}T\\d{2}:\\d{2}:\\d{2}", value)) {
    date_part <- as.Date(substr(value, 1, 10))
    time_part <- as.POSIXct(value, format = "%Y-%m-%dT%H:%M:%S")
    format_code <- format_date(date_part, format_code)
    return(format_time(time_part, format_code))
  }
  return(format_date(value, format_code))
}

format_fraction <- function(value, format_code) {
  # Simplify the fraction
  gcd <- function(a, b) if (b == 0) a else gcd(b, a %% b)
  
  if (grepl("# ?/?", format_code)) {
    # Mixed fraction case
    whole_part <- floor(value)
    fraction_part <- abs(value - whole_part)
    
    if (fraction_part == 0) {
      return(as.character(whole_part))
    }
    
    numerator <- round(fraction_part * 100)
    denominator <- 100
    divisor <- gcd(numerator, denominator)
    numerator <- numerator / divisor
    denominator <- denominator / divisor
    
    if (whole_part > 0) {
      return(paste0(whole_part, " ", numerator, "/", denominator))
    } else {
      return(paste0(numerator, "/", denominator))
    }
  } else if (grepl("?/?", format_code)) {
    # Improper fraction case
    numerator <- round(value * 100)
    denominator <- 100
    divisor <- gcd(numerator, denominator)
    numerator <- numerator / divisor
    denominator <- denominator / divisor
    
    return(paste0(numerator, "/", denominator))
  }
  
  return(as.character(value))
}

format_text <- function(value, format_code) {
  
  # remove potentially escaped quotation marks
  format_code <- gsub("\\\"", "", format_code)
  
  if (!is.character(value)) {
    return(gsub("@", "", format_code)) # Remove placeholder if value is not text
  }
  if (!grepl("[Hhms]", format_code) || !grepl(":", format_code)) {
    return(gsub("@", value, format_code, fixed = TRUE))
  }
  return(format_code)
}

ooxml_format <- function(value, format_code) {
  
  format_code <- openxlsx2:::replaceXMLEntities(format_code)
  formats <- unlist(strsplit(format_code, ";"))
  format_code <- formats[1]
  
  if (is.numeric(value) && sign(value) < 0 && length(formats) > 1) {
    format_code <- ifelse(length(formats) > 1, formats[2], formats[1])
  } else if (value == 0 && length(formats) > 2) {
    format_code <- ifelse(length(formats) > 2, formats[3], formats[1])
  } else if (is.character(value) && length(formats) > 2) {
    format_code <- ifelse(length(formats) > 3, formats[4], "@")
  }
  
  meta <- analyze_number_format(format_code)
  
  # drop potential color parts like "[Red]"
  format_code <- gsub("\\[.*?\\]", "", format_code)
  format_code <- replace_after_underscore(format_code)
  # message(format_code)
  
  if (meta$is_pct) {
    format_code <- gsub("%", "", format_code)
    value <- value * 100
  }
  
  out <- NULL
  
  # Main function logic
  if (grepl("/[0#?]", format_code)) { # TODO the questionmark is not unique to fractions
    out <- format_fraction(value, format_code)
  } else if (grepl("[Hhms]", format_code, ignore.case = TRUE) && grepl("[ymd]", format_code, ignore.case = TRUE)) {
    out <- format_combined(value, format_code)
  } else if (grepl("[Hhms]", format_code, ignore.case = TRUE) && grepl(":", format_code)) {
    out <- format_time(value, format_code)
  } else if (grepl("[ymd]", format_code, ignore.case = TRUE)) {
    if (inherits(value, "Date") || grepl("\\d{4}-\\d{2}-\\d{2}", value)) {
      out <- format_date(value, format_code)
    } else {
      out <- format_text(value, format_code) # Fallback to text if value is not a date
    }
  } else if (grepl("@", format_code)) {
    out <- format_text(value, format_code)
  } else if (grepl("#|0", format_code)) {
    out <- format_number(value, format_code)
  } else if (grepl("?", format_code)) {
    # format_code <- gsub("?", "", format_code)
    # this is somewhat speculation
    if (grepl("\"-\"", format_code)) format_code <- "-"
    out <- format_text(value, format_code)
  } else {
    stop("Unsupported or invalid format code.")
  }
  
  # message(format_code)
  # print(meta)
  
  if (!is.na(meta$currency)) {
    if (!meta$is_currency_at_back)
      out <- paste(meta$currency, out)
    
    if (meta$is_currency_at_back)
      out <- paste(out, meta$currency)
  }
  
  if (meta$is_pct) out <- paste0(out, "%")
  
  out
}

# Example usage:
# Formatting a number
ooxml_format(1234.5678, "#,##0.00")
#> [1] "1,234.57"
ooxml_format(pi, "#,##0")
#> [1] "3"
ooxml_format(pi, "0,000")
#> [1] "0,003"
ooxml_format(123456789, "#,###,,")
#> [1] "123"

# Formatting a date
ooxml_format("2025-01-05", "yyyy-mm-dd")
#> [1] "2025-01-05"

ooxml_format("2025-01-05", "m/d/yyyy")
#> [1] "1/5/2025"

ooxml_format("2025-01-05", "mm/dd/yy")
#> [1] "01/05/25"

# Formatting a time
ooxml_format("2025-01-05T13:45:30", "hh:mm:ss AM/PM")
#> [1] "01:01:30 PM"

ooxml_format("2025-01-05T13:45:30", "HH:mm:ss")
#> [1] "13:01:30"

# Formatting combined date and time
ooxml_format("2025-01-05T13:45:30", "yy-mmm-dd HH:mm:ss")
#> [1] "25-Jan-05 13:01:30"

# Formatting a fraction
ooxml_format(0.75, "# ?/?")
#> [1] "3/4"
ooxml_format(1.75, "# ?/?")
#> [1] "1 3/4"

# Formatting a text
ooxml_format("Hello", "Hello @")
#> [1] "Hello Hello"

ooxml_format(-1234.56, "(#,###.00)")
#> [1] "(1,234.56)"

format_number(3, "0,000")
#> [1] "0,003"

fmt <- '#,###.00_);[Red](#,###.00);0.00;"gross receipts for "@'

ooxml_format(1234.5678, fmt)
#> [1] "1,234.568"
ooxml_format(-1234.5678, fmt)
#> [1] "(1,234.57)"
ooxml_format(0, fmt)
#> [1] "0.00"
ooxml_format("a", fmt)
#> [1] "gross receipts for a"

fmt <- "_-[$£-809]* #,##0.00_-;\\-[$£-809]* #,##0.00_-;_-[$£-809]* &quot;-&quot;??_-;_-@_-"
ooxml_format(1234.5678, fmt)
#> [1] "£ 1,234.568"
ooxml_format(-1234.5678, fmt)
#> [1] "£ -1,234.568"

fmt <- "_- [$£-809]* #,##0.00_-;\\- [$£-809]* #,##0.00_-; [Red]-[$£-809]* &quot;-&quot;??_-;_-@_-"
# fmt <- openxlsx2:::replaceXMLEntities(fmt)
# replace_after_underscore(strsplit(fmt, ";")[[1]][[3]])

ooxml_format(12345.13456, fmt)
#> [1] "£ 12,345.135"
ooxml_format(-12345.13456, fmt)
#> [1] "£ -12,345.135"
ooxml_format(0, fmt)
#> [1] "£ -"

fmt <- "[$€-2] #,##0.00_);[Red]([$€-2] #,##0.00)"
ooxml_format(12345.13456, fmt)
#> [1] "€ 12,345.135"
ooxml_format(-12345.13456, fmt)
#> [1] "€ (12,345.13)"
ooxml_format(0, fmt)
#> [1] "€ 0.000"

ooxml_format(0.5, "#.##%")
#> [1] "50.00%"
ooxml_format(1.75, "#%")
#> [1] "175%"