Puzzles no. 499–413

Puzzles

Author: ExcelBI

All files (xlsx with puzzle and R with solution) for each and every puzzle are available on my Github. Enjoy.

Puzzle #499

Interesting numbers are pretty often in scope of our puzzles. Today we have Lynch-Bell Numbers, and we need to find first 500 of them. Why they are special? Because of 4 conditions: none of digits repeat, there is no 0 in it, is at least 2 digits long and it is divisible by all of its digits. So many conditions to code as well. It is case we have pretty memory consuming calculation and it took code about 1.5 to 2 minutes to get 500 hundred of them. Look at it and at the end I will show another solution that is much faster.

Loading data and libraries

library(tidyverse)
library(readxl)
library(tictoc)

path = "Excel/499 Lynch Bell Numbers.xlsx"
test = read_excel(path, range = "A1:A501")

Transformation (with time measuring)

contains_zero <- function(number) {
  any(strsplit(number, "")[[1]] == "0")
}

has_unique_digits <- function(number) {
  digits <- strsplit(number, "")[[1]]
  length(unique(digits)) == length(digits)
}

is_self_dividing <- function(number) {
  digits <- as.numeric(strsplit(number, "")[[1]])
  all(digits != 0 & as.numeric(number) %% digits == 0)
}

get_numbers <- function(number_of_digits) {
  start <- 10^(number_of_digits - 1)
  end <- 10^number_of_digits - 1
  range <- as.character(start:end)
  
  result <- range %>%
    keep(~ !contains_zero(.x) && has_unique_digits(.x) && is_self_dividing(.x))
  
  return(tibble(number = result))
}

tic()
result = map_dfr(2:7, ~ get_numbers(.x)) %>% head(500)
toc()
# 119.52 sec elapsed

Validation

identical(as.numeric(result$number), test$`Answer Expected`)
#> [1] TRUE
Extra solution in Python: only 3 seconds to run

import pandas as pd
import time

path = "499 Lynch Bell Numbers.xlsx"
test = pd.read_excel(path, usecols="A").values.flatten().tolist()

def check_lynchbell(n):
    s = str(n)
    if "0" in s or len(set(s)) < len(s) or n <= 10: return False
    return all(n%int(d) == 0 for d in s)

start_time = time.time()
numbers = [k for k in range(9876543) if check_lynchbell(k)][:500]
end_time = time.time()

execution_time = end_time - start_time

print("Execution time:", execution_time, "seconds") # Execution time: 3.345 seconds
print(test == numbers) # TruePuzzle #500

Sometimes people are not calculating thing regularly, and then need to do much more job at once. And this is how we see this problem table in our task. Person responsible for it just noted total amount, but we need exact number for each point each day. Fortunatelly it is easier that it seems.

And guess what? We already did this task before. Because of some mistake we have this doubled. Solutions are ready here:
https://github.com/kgryczan/excelbi_puzzles/blob/main/Power%20Query/PQ_Challenge_194.R
https://github.com/kgryczan/excelbi_puzzles/blob/main/Power%20Query/PQ_194.py

PowerQuery Puzzle solved with R

Puzzle #501

In today’s matrix we have some hidden patterns, some numbers like golden threads are used couple of times in line. And we need to find them either horizontally or vertically. Let’s check it.

Load libraries and data

library(tidyverse)
library(readxl)

path = "Excel/501 Find Consecutives in Grid.xlsx"
input = read_excel(path, range = "B2:M10", col_names = FALSE) 
test  = read_excel(path, range = "O1:O6")

Transformation

i1 = as.matrix(input)
i2 = t(i1)

find_repeats_in_rows <- function(matrix) {
  unique(unlist(apply(matrix, 1, function(row) {
    row[which(diff(row) == 0)]
  })))
}

result = union(find_repeats_in_rows(i1),
               find_repeats_in_rows(i2)) %>%
  sort() %>%
  as_tibble() %>%
  setNames("Answer Expected")

Validation

identical(result, test)
# [1] True                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                           1] TRUE                                                                                                                                                                                                                                                                                                                                                                          

Puzzle #502

Sometimes to construct something new we have to deconstruct something old. And we need to remove some digits to find maximal number that is cube, but is also contains digits from given numbers. But we can also remove some digit if it helps achieving goal. And as result we need to show this max cube and digits we are removing. Find out how to do it.

Loading libraries and data

library(tidyverse)
library(readxl)

path = "Excel/502 Remove Minimum Digits to Make a Cube.xlsx"
input = read_excel(path, range = "A2:A10")
test  = read_excel(path, range = "B2:C10")

Transformation

cube_number <- function(number) {
  str_nums <- str_split(as.character(number), "")[[1]]
  digits_combinations <- map(1:(length(str_nums) - 1), ~combn(str_nums, ., simplify = FALSE))
  all_combinations <- flatten(digits_combinations) %>% map_chr(~paste(.x, collapse = ""))
  
  cube <- keep(all_combinations, ~ round(as.numeric(.x)^(1/3))^3 == as.numeric(.x)) %>% 
    as.numeric() %>% 
    max(., na.rm = TRUE, finite = TRUE)
  
  if (!is.na(cube)) {
    digits_left <- setdiff(str_nums, str_split(as.character(cube), "")[[1]])
    unique_digits <- unique(digits_left)
    return(list(unique_digits, cube))
  } else {
    return(list("", ""))
  }
}

result <- input %>%
  mutate(result = map(Numbers, cube_number)) %>%
  mutate(`Removed Digits` = map_chr(result, ~ pluck(.x, 1) %>% sort(.) %>% paste(collapse = ", ")),
         `Cube Number` = map_chr(result, ~ pluck(.x, 2) %>% as.character)) %>%
  mutate(`Removed Digits` = if_else(nchar(Numbers) == str_count(`Removed Digits`, "\\d"), NA, `Removed Digits`),
         `Cube Number` = if_else(`Removed Digits` == "", NA, as.numeric(`Cube Number`))) %>%
  select(-c(result, Numbers))

Validation

all.equal(result, test, check.attributes = FALSE)
# [1] TRUE

Puzzle #503

What we have here? Probably records from American receipts. Why American, because in other (at least western) countries taxes are included in shelf prices, unlike in USA. So today we have amounts without taxes, we know that tax is 10% except some groceries. So we need to calculate how much each customer have to pay. Let’s do it.

Loading libraries and data

library(tidyverse)
library(readxl)

path = "Excel/503 Payments Calculations.xlsx"
input1 = read_excel(path, range = "A1:B9")
input2 = read_excel(path, range = "D1:D9") %>% pull()
test = read_excel(path, range = "F1:L9")
colnames(test)[1] = "Customer"

Transformation

result = input1 %>%
  separate_rows(`Purchase product (Tax not included)`, sep = ", ") %>%
  separate(`Purchase product (Tax not included)`, into = c("Product","Amount"), sep = ": ") %>%
  mutate(Amount = str_remove_all(Amount, ",") %>% as.numeric(),
         amount_with_tax = ifelse(Product %in% input2, Amount, Amount * 1.1)) %>%
  summarise(SUM = sum(Amount),
            AVERAGE = mean(Amount),
            MAX = max(Amount),
            MIN = min(Amount),
            COUNT = n() %>% as.numeric(),
            Payment = sum(amount_with_tax),
            .by = Customer)

Validation

all.equal(result, test)
# Column Payment has wrong value in test data

Puzzle #504

Finally some text manipulation. But pretty easy. Among list of all U.S. Presidents we need to find those whose initials are all the same.

Loading libraries and data

library(tidyverse)
library(readxl)

path = "Excel/504 US Presidents All First Chars Same.xlsx"
input = read_excel(path, range = "A1:A47")
test = read_excel(path, range = "B1:B5")

Transformation

result = input %>%
  filter(map(`US Presidents`,  ~ length(str_extract_all(., "[A-Z]") %>% 
                                          unlist() %>% unique())) == 1)

Validation

identical(result$`US Presidents`, test$`Answer Expected`)
# [1] TRUE

Puzzle #505

Sometimes our task is to build structure of numbers or letters. And today we are placing whole English alphabet on pyramid. As usual in such cases I prefer do it using matrices.

Loading libraries and data

library(dplyr)
library(purrr)

Transformation

create_triangular_dataframe <- function(letters) {
  n <- max(which((1:10 * (1:10 + 1)) / 2 <= length(letters)))
  num_rows <- n + 1
  num_cols <- n * 2 + 1
  
  df <- data.frame(matrix("", nrow = num_rows, ncol = num_cols))
  
  letters_idx <- 1
  
  fill_row <- function(row_num, num_letters) {
    start_col <- (num_cols - (2 * num_letters - 1)) %/% 2 + 1
    df[row_num, seq(start_col, by = 2, length.out = num_letters)] <<- letters[letters_idx:(letters_idx + num_letters - 1)]
    letters_idx <<- letters_idx + num_letters
  }
  
  walk(1:n, ~ fill_row(.x, .x))
  
  fill_row(num_rows, length(letters) - (n * (n + 1)) / 2)

  colnames(df) <- LETTERS[1:ncol(df)]  
  print(df, row.names = FALSE)
}

df = create_triangular_dataframe(LETTERS)

Puzzle #506

Imagine that 5 people assigned with letters A to E, are taking numbers from drawers. Some numbers are in ranges so we need to expand them, but then each person in order is placing its first number, then second number in next round and so on untill end of numbers. Doesn’t have sense in reality, but as excercise of mind it is pretty nice. Let’s do it.

Loading libraries and data

library(tidyverse)
library(readxl)

path = "Excel/506 Align Concated Alphabets & Numbers.xlsx"
input = read_excel(path, range = "A1:B6")
test = read_excel(path, range = "C1:C22")

Transformation

replace_range <- function(input) {
  input %>%
    str_split(", ") %>%
    unlist() %>%
    map_chr(~ if (str_detect(.x, "-")) {
      range <- str_split(.x, "-")[[1]] %>%
        as.numeric()
      paste(seq(range[1], range[2]), collapse = ", ")
    } else {
      .x
    }) %>%
    paste(collapse = ", ")
}

result = input %>%
  mutate(Numbers = map_chr(Numbers, replace_range) %>% str_split(., ", ")) %>%
  unnest_wider(Numbers, names_sep = "_") %>%
  pivot_longer(cols = starts_with("Numbers"), values_to = "Value", names_to = NULL,  cols_vary = "slowest") %>%
  filter(!is.na(Value)) %>%
  unite("Expected Answer", c("Alphabets", "Value"), sep = "") %>%
  select("Expected Answer")

Validation

identical(result$`Expected Answer`, test$`Expected Answer`)
# [1] TRUE  

Puzzle #507

Numbers are a part of language and culture. So today we have task to sort elements of dates spoken out as words, and then check if they are sorted alphabetically. Check it.

Loading libraries and data

library(tidyverse)
library(readxl)
library(english)

path = "Excel/507 Lexically Sorted MDY Dates.xlsx"
input = read_excel(path, range = "A1:A10")
test  = read_excel(path, range = "B1:B4")  

Transformation

result = input %>%
  mutate(parts = str_match(Dates, '(\\d{2})(\\d{2})(\\d{4})'),
         lit_month = month.name[as.integer(parts[,2])],
         lit_day = as.character(english(as.integer(parts[,3]))),
         lit_year = as.character(english(as.integer(parts[,4])))) %>%
  mutate(
    is_alphabetical = pmap_lgl(list(lit_month, lit_day, lit_year), 
                               ~ {
                                 lit_date <- c(..1, ..2, ..3)
                                 identical(lit_date, sort(lit_date))
                               })
  ) %>%
  filter(is_alphabetical) %>%
  select(`Expected Answer` = Dates)

Validation

identical(result, test)
# [1] TRUE

Puzzle #508

Again we have some number generation. Now we need numbers that are perfect square and square of its digits also sums up to perfect square. Those number are just oversquared 😀 But it is not that hard as it could. Although generating sequences can be time consuming, this time it is pretty fast. Check it out.

Loading libraries and data

library(tidyverse)
library(readxl)

path = "Excel/508 Number is Perfect Square and Sum of Squares of Digits is also a Perfect Square.xlsx"
test = read_excel(path, range = "A1:A501")

Transformation

is_perfect_square <- function(n) {
  sqrt_n <- sqrt(n)
  sqrt_n == floor(sqrt_n)
}

result <- integer(0)
i <- 1


while (length(result) < 500) {
  if (nchar(as.character(test[i, 1])) > 1) {
    if (is_perfect_square(test[i, 1]) && is_perfect_square(sum(as.numeric(strsplit(as.character(test[i, 1]), "")[[1]])^2))) {
      result <- c(result, test[i, 1])
    }
  }
  i <- i + 1
}

result = data.frame(Result =  unlist(result))

Validation

identical(result$Result, test$`Answer Expected`)
# [1] TRUE

Puzzle #509

If you are interested in computer science or math, I am almost sure that you know what Pascal’s Triangle is. But today we don’t need to simply generate such triangle, but also calculate sum of columns of numbers that are creating it. So we need to create two function for it. Look at it.

Loading libraries and data

library(tidyverse)
library(readxl)

path = "Excel/509 Pascal Triangle Column Sums.xlsx"
input = read_excel(path, range = "A1:A5")
test = read_excel(path, range = "B1:B5") %>%
  mutate(`Answer Expected` = ifelse(`Answer Expected` == "1, 1", "1, 1, 1", `Answer Expected`))

Transformation

generate_pascal_triangle = function(n) {
  triangle = matrix(0, n, 2*n - 1)
  triangle[1, n] = 1

  for (i in 2:n) {
    for (j in 1:(2*n - 1)) {
      if (j == 1) {
        triangle[i, j] <- triangle[i - 1, j + 1]
      } else if (j == 2*n - 1) {
        triangle[i, j] <- triangle[i - 1, j - 1]
      } else {
        triangle[i, j] <- triangle[i - 1, j - 1] + triangle[i - 1, j + 1]
      }
    }
  }
  return(triangle)
}

colsum_pascal_triangle = function(n) {
  triangle = generate_pascal_triangle(n)
  colsum = colSums(triangle) %>%
    paste(collapse = ", ")
  return(colsum)
}

result = input %>%
  mutate(`Answer Expected` = map_chr(Rows, colsum_pascal_triangle)) %>%
  select(`Answer Expected`)

Validation

identical(result, test)
# [1] TRUE

Puzzle #510

I like this task a lot. It is probably one of my favourite. We just need to split random string and count how many characters of each class are there. How many capital letters, how many digits, punctuators and specials and of course lower letters. Enjoy!

Loading libraries and data

library(tidyverse)
library(readxl)

path = "Excel/510 Find Upper, Lower, Numbers & Special Chars Count.xlsx"
input = read_excel(path, range = "A2:A12")
test  = read_excel(path, range = "B2:E12")

Transformation

result = input %>% 
  mutate(
    Data = ifelse(is.na(Data), "", Data),
    `Upper Case` = str_count(Data, "[A-Z]"),
    `Lower Case` = str_count(Data, "[a-z]"),
    Numbers = str_count(Data, "[0-9]"),
    `Special Chars` = str_count(Data, "[^A-Za-z0-9]")
  ) %>%
  select(-Data) %>%
  mutate(across(everything(), as.numeric))

Validation

identical(test, result)
# [1] TRUE

Puzzle # 511

Pig Latin is form of encrypting messages by cutting word in certain place, change the order of parts, and then adding “ay” at the end. But today we don’t have to code it, but to decrypt it. As many people spotted, reverse logic for Pig Latin is not best. Decrypted words can be different that encoded. So I find another way and decided to look for all possible real words that could be encoded. Find out my solution.

Loading libraries and data

library(tidyverse)
library(readxl)
library(hunspell)

path = "Excel/511 Pig Latin Decrypter.xlsx"
input = read_excel(path, range = "A1:A10")
test = read_excel(path, range = "B1:B10")

Transformation

rotate_word <- function(word, n) {
  len <- nchar(word)
  if (n >= len) return(word)
  substr(word, n + 1, len) %>% paste0(substr(word, 1, n))
}
decrypt_pig_latin <- function(sentence) {
  words <- str_split(sentence, " ")[[1]]
  decrypted_words <- words %>% map_chr(~ {
    word <- str_remove(.x, "ay[[:punct:]]?$")
    punctuation <- str_extract(.x, "[[:punct:]]$")
    len <- nchar(word)
    possible_words <- map_chr(0:(len - 1), ~ rotate_word(word, .x))
    valid_words <- possible_words %>% keep(hunspell_check)
    if (length(valid_words) > 0) {
      concatenated_valid_words <- paste(valid_words, collapse = "/")
      if (!is.na(punctuation)) {
        return(paste0(concatenated_valid_words, punctuation))
      } else {
        return(concatenated_valid_words)
      }
    } else {
      return(.x)
    }
  })
  paste(decrypted_words, collapse = " ")
}

result = input %>%
  mutate(`Answer Expected` = map_chr(`Encrypted Text`, decrypt_pig_latin)) %>%
  select(`Answer Expected`)

Validation

result == test
# Answer Expected
# [1,]            TRUE
# [2,]            TRUE
# [3,]            TRUE
# [4,]            TRUE
# [5,]            TRUE
# [6,]            TRUE
# [7,]            TRUE
# [8,]            FALSE who/how was your weekend?
# [9,]            TRUE

Puzzle #512

This task was one of the most suprising to me, and one when I first time used binary manipulations. We need to find first sparse number that is bigger than given number. What sparse means? That in its binary representations we do not find any pair, triplet or bigger set of adjacent 1s. I will provide you with 2 solutions, but first is only working for smaller numbers (it didn’t manage to make last to numbers in reasonable time) and second one using binary calculations which is very fast and don’t have problem with largest numbers.

Loading libraries and data

library(tidyverse)
library(readxl)

path = "Excel/512 Next Sparse Number.xlsx"
input = read_excel(path, range = "A1:A10")
test  = read_excel(path, range = "B1:B10")

Transformation — slow method

next_sparse_number_slow <- function(n) {
  is_sparse <- function(n) {
    binary_n <- intToBits(n)
    for (i in 2:length(binary_n)) {
      if (binary_n[i] == 1 && binary_n[i - 1] == 1) {
        return(FALSE)
      }
    }
    return(TRUE)
  }
  detect((n + 1):(2 * n + 1), is_sparse)
}

result = input %>%
  mutate(`Answer Expected` = map_dbl(Number, next_sparse_number_slow))

Transformation — fast binary method

next_sparse_number_fast <- function(n) {
  repeat {
    m <- n
    k <- 0
    change_required <- FALSE

    while (m > 0) {
      if ((m %% 4) == 3) {
        change_required <- TRUE
        break
      }
      m <- m %/% 2
      k <- k + 1
    }
    
    if (!change_required) break
    
    n <- (n %/% (2^(k + 1))) * (2^(k + 1)) + (2^(k + 1))
  }
  return(n)
}


result = input %>%
  mutate(`Answer Expected` = map_dbl(Number, next_sparse_number_fast))

# Code explanation for those not familiar with binary manipulations.
Initialize Variables:  
    Start with m as the input number n.
    Set k to 0, which keeps track of the bit position.
    Set a flag change_required to FALSE, indicating whether we need to modify the number.
Loop Until Sparse:
    We enter a loop that continues until we find a sparse number.
Check for Consecutive '1's:
    For each bit in m:
        If the last two bits are both '1' (checked using (m %% 4) == 3), it means the number isn't sparse. 
          We set change_required to TRUE and exit the inner loop.
        If not, move to the next bit by dividing m by 2 and incrementing k.
Adjust the Number if Needed:
    If change_required is TRUE (i.e., we found consecutive '1's):
    Calculate the new n by clearing bits from position k onwards and setting the next higher bit.
Return the Sparse Number:
    Once we have a number without consecutive '1's (change_required is FALSE), the loop stops, and we return the number n.

In Short:
The function checks each bit of the number to find if there are two '1's in a row. 
If it finds them, it changes the number to remove these consecutive '1's and tries again. 
This continues until the number is "sparse" (has no consecutive '1's), and then it returns that number.

Validation

identical(result$`Answer Expected`, test$`Answer Expected`)
#> [1] TRUE

Puzzle #513

And usually after having hard one, there is easy puzzle. Today we need to sort given number by their last digit, and if there was more than one with identical, go in order of original. Check it out.

Loading libraries and data

library(tidyverse)
library(readxl)
library(stringi)

path = "Excel/513 Sort by Unit Digit.xlsx"
input = read_excel(path, range = "A1:A10")
test  = read_excel(path, range = "B1:B10")

Transformation

result = input %>%
  arrange(str_sub(Numbers, -1)) 

Validation

identical(result$Numbers, test$`Answer Expected`)
# TRUE

Feel free to comment, share and contact me with advices, questions and your ideas how to improve anything. Contact me on Linkedin if you wish as well.
On my Github repo there are also solutions for the same puzzles in Python. Check it out!

R Solution for Excel Puzzles was originally published in Numbers around us on Medium, where people are continuing the conversation by highlighting and responding to this story.