├── .RData ├── .Rhistory ├── .github ├── ISSUE_TEMPLATE │ ├── bug_report.md │ └── feature_request.md └── workflows │ └── main.yml ├── CODE_OF_CONDUCT.md ├── CONTRIBUTING.md ├── LICENSE ├── README.md ├── figures ├── Collatz_Conjecture.R ├── Logo_with_predicition_function.png ├── QRCode_animation.gif ├── UURlogo.jpg ├── doppler_shift.R ├── entropy_tweet_visualization.png └── fermi_calculator.R ├── functions ├── .RData ├── .Rhistory ├── ASCII_image.R ├── Absurd_Converter.R ├── AnalogClock.R ├── Animate_dataset.R ├── AnimatingProbabilityPlots.R ├── AnscombeQuartet.R ├── Benchmark_test.R ├── BigDigitalClock.R ├── Bionic_Reading.R ├── BrierScore.R ├── Call_StatsfunR.R ├── Catalan_number.R ├── Chicken_egg_problem.R ├── Cognitive Bias.R ├── ColorfulPlot.R ├── Concurrency_simulations.R ├── Convert_text_to_numbers.R ├── Creating_QR_code.R ├── DataFrameMaker.R ├── Dataframe_to_markdown.R ├── DrawCalendar.R ├── DrawFunctionCodeOnConsole.R ├── DrawLetter.R ├── Drawing_Recursions.R ├── DynamicVariableInString.R ├── Dynamic_R.R ├── Eight_R_Tidyverse_tips_for_better_data_engineering.R ├── EncryptText.R ├── ExceptionHandling.R ├── Falling_snow.R ├── FindingMaximumOfSubarrays.R ├── Flakes.R ├── FolderTreemap.R ├── FourInARow.R ├── Four_Fours.R ├── Friday13.R ├── FromSQLtodplyr.R ├── FunctionNames.R ├── FunctionTwist.R ├── GARCH.R ├── GenerateCalculator.R ├── GenerateCalculatorCode.R ├── GenerateQRCode.R ├── Generate_data_with_correlations.R ├── GeneratingCookingRecipes.R ├── Generating_image.R ├── Github_HeatMap.R ├── Goldbach_conjecture.R ├── HelloRversion.R ├── HelloRversion_HelperFile.R ├── InteractiveVoronoiGraphGenerator.R ├── IsDatasetSame.R ├── IsItFullMoon.R ├── IsItRaining.R ├── KadaneAlgorithm.R ├── Knapsack.R ├── L-Systems.R ├── L-systems2.R ├── LLM.R ├── LearningIrregularVerbs.R ├── LetterFrequencyNumbers.R ├── Leveshtein.R ├── List_performances.R ├── LoremIpsum.R ├── MakingScatterPlotFromImage.R ├── MandelbrotSet.R ├── Markov_babbler.R ├── MastermindGame.R ├── MergeR_SQLJoin.R ├── MicrosoftLogo.R ├── MixedCases.R ├── NumberCountdownGame.R ├── PackageFrequencies.R ├── Pareidolia_calendar.R ├── Pipe4ggplot2.R ├── Plot_showcase.R ├── Plotting_photos.R ├── PsychedelicSquareRoot.R ├── QR-Code_time.R ├── R-squared.R ├── RJobTitleGenerator.R ├── R_dataFrame_to_Python_Dataframe.R ├── R_fibonacci_benchmarks.R ├── Random_image_stopifnot.R ├── ReverseInteger.R ├── RockPaperScissors.R ├── SQL_R.R ├── SelfCommit.R ├── ShortenURL.R ├── SimpleCardGame.R ├── SmallMultipleGraphs.R ├── Spiral_Matrix.R ├── Stats_fun.R ├── TSQL_2048.sql ├── TryCatch_errorHandling.R ├── TwoSum_CanSum.R ├── UselessFun_API.R ├── UselessSort.R ├── Useless_API.R ├── ValentinePoem.R ├── Vanishing_sentence.R ├── Variables_loop_plot.R ├── WackyPasswordGenerator.R ├── Weierstrass_function.R ├── WordScrambler.R ├── YearProgress.R ├── all_time_useless.R ├── apply.R ├── binary_octal_decimal_conversion.R ├── climate_spiral.R ├── collatz_function.R ├── confuser_animation.gif ├── confuser_report.md ├── custom_pallete.R ├── digitalClock.R ├── distro_animation.R ├── dplyrAhaMoments.R ├── entropy_meter.R ├── fireworks.R ├── fun_in_fun.R ├── ggplot_tornado.R ├── greedy_TSP.R ├── happyDino_head.png ├── happy_dino.R ├── image_with_image.R ├── install_packages_requirements.R ├── iris_py.py ├── knapsack_v2.R ├── mathart.R ├── multiplication_table.R ├── pretty_dataframe_definitions.R ├── requirements.txt ├── reverse_hello_world.R ├── schedule_builder.R ├── signature.R ├── twin_dragon_fractal.R ├── useless house.R ├── vanishing_sentence.gif └── while_true_function.R └── image ├── Plot_theme_ggplot2.png ├── amazonLogo.jpg ├── anim_decibel.gif ├── appleLogo.jpg ├── geniLogo.jpg ├── ljubljana.jpg ├── ljubljana2.jpg ├── myiriscompany.png ├── nbalogo.jpg ├── nikeLogo.jpg ├── sparkLogo.jpg └── windowsLogo.jpg /.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/.RData -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/bug_report.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Bug report 3 | about: Create a report to help us improve 4 | title: '' 5 | labels: '' 6 | assignees: '' 7 | 8 | --- 9 | 10 | **Describe the bug** 11 | A clear and concise description of what the bug is. 12 | 13 | **To Reproduce** 14 | Steps to reproduce the behavior: 15 | 1. Go to '...' 16 | 2. Click on '....' 17 | 3. Scroll down to '....' 18 | 4. See error 19 | 20 | **Expected behavior** 21 | A clear and concise description of what you expected to happen. 22 | 23 | **Screenshots** 24 | If applicable, add screenshots to help explain your problem. 25 | 26 | **Desktop (please complete the following information):** 27 | - OS: [e.g. iOS] 28 | - Browser [e.g. chrome, safari] 29 | - Version [e.g. 22] 30 | 31 | **Smartphone (please complete the following information):** 32 | - Device: [e.g. iPhone6] 33 | - OS: [e.g. iOS8.1] 34 | - Browser [e.g. stock browser, safari] 35 | - Version [e.g. 22] 36 | 37 | **Additional context** 38 | Add any other context about the problem here. 39 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/feature_request.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Feature request 3 | about: Suggest an idea for this project 4 | title: '' 5 | labels: '' 6 | assignees: '' 7 | 8 | --- 9 | 10 | **Is your feature request related to a problem? Please describe.** 11 | A clear and concise description of what the problem is. Ex. I'm always frustrated when [...] 12 | 13 | **Describe the solution you'd like** 14 | A clear and concise description of what you want to happen. 15 | 16 | **Describe alternatives you've considered** 17 | A clear and concise description of any alternative solutions or features you've considered. 18 | 19 | **Additional context** 20 | Add any other context or screenshots about the feature request here. 21 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | # This is a basic workflow to help you get started with Actions 2 | 3 | name: CI & Send a tweet when adding new function 4 | 5 | # Controls when the workflow will run 6 | on: 7 | # Triggers the workflow on push or pull request events but only for the main branch 8 | push: 9 | branches: [ main ] 10 | pull_request: 11 | branches: [ main ] 12 | 13 | # Allows you to run this workflow manually from the Actions tab 14 | workflow_dispatch: 15 | 16 | # A workflow run is made up of one or more jobs that can run sequentially or in parallel 17 | jobs: 18 | # This workflow contains a single job called "build" 19 | build: 20 | # The type of runner that the job will run on 21 | runs-on: ubuntu-latest 22 | 23 | # Steps represent a sequence of tasks that will be executed as part of the job 24 | steps: 25 | - uses: ethomson/send-tweet-action@v1 26 | with: 27 | status: "New Function added to Useless Usefull R functions" 28 | consumer-key: ${% raw %}{{ secrets.TWITTER_CONSUMER_API_KEY }}{% endraw %} 29 | consumer-secret: ${% raw %}{{ secrets.TWITTER_CONSUMER_API_SECRET }}{% endraw %} 30 | access-token: ${% raw %}{{ secrets.TWITTER_ACCESS_TOKEN }}{% endraw %} 31 | access-token-secret: ${% raw %}{{ secrets.TWITTER_ACCESS_TOKEN_SECRET }}{% endraw %} 32 | 33 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Covenant Code of Conduct 2 | 3 | ## Our Pledge 4 | 5 | In the interest of fostering an open and welcoming environment, we as 6 | contributors and maintainers pledge to making participation in our project and 7 | our community a harassment-free experience for everyone, regardless of age, body 8 | size, disability, ethnicity, sex characteristics, gender identity and expression, 9 | level of experience, education, socio-economic status, nationality, personal 10 | appearance, race, religion, or sexual identity and orientation. 11 | 12 | ## Our Standards 13 | 14 | Examples of behavior that contributes to creating a positive environment 15 | include: 16 | 17 | * Using welcoming and inclusive language 18 | * Being respectful of differing viewpoints and experiences 19 | * Gracefully accepting constructive criticism 20 | * Focusing on what is best for the community 21 | * Showing empathy towards other community members 22 | 23 | Examples of unacceptable behavior by participants include: 24 | 25 | * The use of sexualized language or imagery and unwelcome sexual attention or 26 | advances 27 | * Trolling, insulting/derogatory comments, and personal or political attacks 28 | * Public or private harassment 29 | * Publishing others' private information, such as a physical or electronic 30 | address, without explicit permission 31 | * Other conduct which could reasonably be considered inappropriate in a 32 | professional setting 33 | 34 | ## Our Responsibilities 35 | 36 | Project maintainers are responsible for clarifying the standards of acceptable 37 | behavior and are expected to take appropriate and fair corrective action in 38 | response to any instances of unacceptable behavior. 39 | 40 | Project maintainers have the right and responsibility to remove, edit, or 41 | reject comments, commits, code, wiki edits, issues, and other contributions 42 | that are not aligned to this Code of Conduct, or to ban temporarily or 43 | permanently any contributor for other behaviors that they deem inappropriate, 44 | threatening, offensive, or harmful. 45 | 46 | ## Scope 47 | 48 | This Code of Conduct applies both within project spaces and in public spaces 49 | when an individual is representing the project or its community. Examples of 50 | representing a project or community include using an official project e-mail 51 | address, posting via an official social media account, or acting as an appointed 52 | representative at an online or offline event. Representation of a project may be 53 | further defined and clarified by project maintainers. 54 | 55 | ## Enforcement 56 | 57 | Instances of abusive, harassing, or otherwise unacceptable behavior may be 58 | reported by contacting the project team at tomaz.kastrun@gmail.com. All 59 | complaints will be reviewed and investigated and will result in a response that 60 | is deemed necessary and appropriate to the circumstances. The project team is 61 | obligated to maintain confidentiality with regard to the reporter of an incident. 62 | Further details of specific enforcement policies may be posted separately. 63 | 64 | Project maintainers who do not follow or enforce the Code of Conduct in good 65 | faith may face temporary or permanent repercussions as determined by other 66 | members of the project's leadership. 67 | 68 | ## Attribution 69 | 70 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4, 71 | available at https://www.contributor-covenant.org/version/1/4/code-of-conduct.html 72 | 73 | [homepage]: https://www.contributor-covenant.org 74 | 75 | For answers to common questions about this code of conduct, see 76 | https://www.contributor-covenant.org/faq 77 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to Useless R functions repository 2 | 3 | :+1::tada: Thank you all for taking the time to contribute! :tada::+1: 4 | 5 | How Can I Contribute? 6 | * Reporting Bugs :bug: 7 | * Suggesting Enhancements 8 | * Your First Code Contribution 9 | * Pull Requests 10 | * Suggest useless R functions 11 | * Fork and enhance 12 | * Test the code on different versions of R or OS 13 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Tomaz Kastrun 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /figures/Collatz_Conjecture.R: -------------------------------------------------------------------------------- 1 | # Collatz Conjecture 2 | 3 | 4 | library(ggplot2) 5 | 6 | 7 | collatz_sequence <- function(n) { 8 | if (n <= 0) stop("Input must be a positive integer.") 9 | sequence <- n 10 | while (n != 1) { 11 | n <- ifelse(n %% 2 == 0, n / 2, 3 * n + 1) 12 | sequence <- c(sequence, n) 13 | } 14 | return(sequence) 15 | } 16 | 17 | # Collatz Explorer 18 | collatz_explorer <- function(start, output_file = NULL) { 19 | collatz_seq <- collatz_sequence(start) 20 | print(collatz_seq) 21 | data <- data.frame( 22 | step = seq_along(collatz_seq), 23 | value = collatz_seq 24 | ) 25 | print(head(data, 100)) 26 | p <- ggplot(data, aes(x = step, y = value)) + 27 | geom_line(color = "blue", size = 1) + 28 | geom_point(color = "red", size = 2) + 29 | scale_y_log10() + # log 30 | theme_minimal() + 31 | theme( 32 | plot.title = element_text(size = 16, face = "bold", hjust = 0.5), 33 | plot.subtitle = element_text(size = 12, hjust = 0.5), 34 | axis.title = element_text(size = 14), 35 | axis.text = element_text(size = 12) 36 | ) + 37 | labs( 38 | title = "Collatz Explorer", 39 | subtitle = paste("Starting number:", start), 40 | x = "Step", 41 | y = "Value (Log Scale)" 42 | ) 43 | 44 | 45 | if (!is.null(output_file)) { 46 | ggsave(output_file, p, width = 8, height = 6) 47 | message("Plot saved to ", output_file) 48 | } else { 49 | print(p) 50 | } 51 | } 52 | 53 | # Example usage 54 | collatz_explorer(604050036) 55 | -------------------------------------------------------------------------------- /figures/Logo_with_predicition_function.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/figures/Logo_with_predicition_function.png -------------------------------------------------------------------------------- /figures/QRCode_animation.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/figures/QRCode_animation.gif -------------------------------------------------------------------------------- /figures/UURlogo.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/figures/UURlogo.jpg -------------------------------------------------------------------------------- /figures/doppler_shift.R: -------------------------------------------------------------------------------- 1 | library(ggplot2) 2 | library(reshape2) 3 | 4 | doppler_shift <- function(frequencies, source_speeds, observer_speed = 0, c = 343) { 5 | shifted_freqs <- outer(frequencies, source_speeds, 6 | function(f, v_s) f * (c + observer_speed) / (c - v_s)) 7 | 8 | return(shifted_freqs) 9 | } 10 | 11 | doppler_colormap <- function(frequencies = seq(100, 1000, by = 50), 12 | source_speeds = seq(-100, 100, by = 10), 13 | observer_speed = 0) { 14 | 15 | # Calculate Doppler-shifted frequencies 16 | shifted_freqs <- doppler_shift(frequencies, source_speeds, observer_speed) 17 | 18 | # Convert to a data frame for ggplot 19 | df <- melt(shifted_freqs) 20 | colnames(df) <- c("Frequency_Index", "Speed_Index", "Shifted_Frequency") 21 | 22 | df$Frequency <- frequencies[df$Frequency_Index] 23 | df$Source_Speed <- source_speeds[df$Speed_Index] 24 | 25 | # Visualization: Heatmap 26 | p <- ggplot(df, aes(x = Source_Speed, y = Frequency, fill = Shifted_Frequency)) + 27 | geom_tile() + 28 | scale_fill_viridis_c(option = "plasma", name = "Observed Frequency (Hz)") + 29 | theme_minimal() + 30 | labs( 31 | title = "Doppler-Shifted Sound Frequency Heatmap", 32 | subtitle = "Color intensity represents the frequency shift due to relative motion", 33 | x = "Source Speed (m/s)", 34 | y = "Original Frequency (Hz)" 35 | ) + 36 | theme( 37 | plot.title = element_text(size = 16, face = "bold", hjust = 0.5), 38 | plot.subtitle = element_text(size = 12, hjust = 0.5), 39 | axis.title = element_text(size = 14), 40 | axis.text = element_text(size = 12) 41 | ) 42 | 43 | print(p) 44 | } 45 | 46 | # Example Usage: 47 | doppler_colormap() 48 | 49 | 50 | 51 | 52 | -------------------------------------------------------------------------------- /figures/entropy_tweet_visualization.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/figures/entropy_tweet_visualization.png -------------------------------------------------------------------------------- /figures/fermi_calculator.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Fermi Calculator 4 | # 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #64 8 | # Created: April 06, 2025 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | 13 | # Changelog: 14 | # 15 | ########################################### 16 | 17 | 18 | library(ggplot2) 19 | library(dplyr) 20 | 21 | fermi_calculator <- function(problem = "piano_tuners_chicago", simulations = 1000) { 22 | 23 | if (problem == "piano_tuners_chicago") { 24 | 25 | pop_chicago <- rnorm(simulations, mean = 2.7e6, sd = 2e5) 26 | households <- pop_chicago / rnorm(simulations, mean = 2.5, sd = 0.2) # ppl per house 27 | pianos_per_household <- rnorm(simulations, mean = 0.02, sd = 0.005) # fraction of pianos per house 28 | pianos_tuned_per_year <- rnorm(simulations, mean = 1, sd = 0.2) # freq of piano tunning 29 | tunings_per_tuner <- rnorm(simulations, mean = 1000, sd = 200) 30 | 31 | num_pianos <- households * pianos_per_household 32 | total_tunings <- num_pianos * pianos_tuned_per_year 33 | num_tuners <- total_tunings / tunings_per_tuner 34 | 35 | 36 | data <- data.frame(NumTuners = num_tuners) 37 | p <- ggplot(data, aes(x = NumTuners)) + 38 | geom_histogram(fill = "blue", color = "black", bins = 30, alpha = 0.7) + 39 | geom_vline(xintercept = mean(num_tuners), color = "red", linetype = "dashed") + 40 | theme_minimal() + 41 | labs(title = "Fermi Estimate: Number of Piano Tuners in Chicago", 42 | subtitle = "Using Monte Carlo Simulation", 43 | x = "Estimated Number of Tuners", 44 | y = "Frequency") 45 | 46 | print(p) 47 | 48 | return(summary(num_tuners)) 49 | } 50 | 51 | else if (problem == "coffee_consumption_ljubljana") { 52 | pop_lj <- rnorm(simulations, mean = 3.6e5, sd = 2e4) # citizens of LJ 53 | fraction_coffee_drinkers <- rnorm(simulations, mean = 0.65, sd = 0.05) 54 | cups_per_day <- rnorm(simulations, mean = 2.5, sd = 0.5) 55 | cup_size_liters <- rnorm(simulations, mean = 0.18, sd = 0.02) # Size of a cup in liters 56 | 57 | daily_coffee_liters <- pop_lj * fraction_coffee_drinkers * cups_per_day * cup_size_liters 58 | data <- data.frame(DailyCoffeeLiters = daily_coffee_liters) 59 | 60 | p <- ggplot(data, aes(x = DailyCoffeeLiters)) + 61 | geom_histogram(fill = "brown", color = "black", bins = 30, alpha = 0.7) + 62 | geom_vline(xintercept = mean(daily_coffee_liters), color = "red", linetype = "dashed") + 63 | theme_minimal() + 64 | labs(title = "Fermi Estimate: Coffee Consumption in Ljubljana", 65 | subtitle = "Using Monte Carlo Simulation", 66 | x = "Liters of Coffee Consumed per Day", 67 | y = "Frequency") 68 | 69 | print(p) 70 | return(summary(daily_coffee_liters)) 71 | } 72 | 73 | else { 74 | stop("Problem not recognized. Try 'piano_tuners_chicago' or 'coffee_consumption_ljubljana'.") 75 | } 76 | } 77 | 78 | 79 | ################# 80 | # function usage 81 | ################# 82 | 83 | fermi_calculator("piano_tuners_chicago") 84 | fermi_calculator("coffee_consumption_ljubljana") 85 | fermi_calculator("drunks_in_dublin") 86 | -------------------------------------------------------------------------------- /functions/.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/functions/.RData -------------------------------------------------------------------------------- /functions/ASCII_image.R: -------------------------------------------------------------------------------- 1 | #install.packages("jpeg") 2 | library(jpeg) 3 | library(dplyr) 4 | 5 | #C=strsplit('851+-. ','')[[1]] 6 | #i=jpeg::readJPEG(system.file('img/Rlogo.jpg',package='jpeg'))[c(T,F),,2] 7 | #i[]=C[findInterval(i,quantile(i,p=seq(0,1,,length(C))))] 8 | #cat(apply(i,1,paste,collapse=''),sep='\n') 9 | 10 | 11 | next_char <- list( 12 | ' ' = ' -+', 13 | '0' = '-+|17235469*80&', 14 | '1' = '-+|17235469*80&', 15 | '2' = '-+|17235469*80&', 16 | '3' = '-+|17235469*80&', 17 | '4' = '-+|17235469*80&', 18 | '5' = '-+|17235469*80&', 19 | '6' = '-+|17235469*80&', 20 | '7' = '-+|17235469*80&', 21 | '8' = '-+|17235469*80&', 22 | '9' = '-+|17235469*80&', 23 | '+' = ' -+!10', 24 | '-' = ' -+!10', 25 | '!' = ' -+!10', 26 | '*' = ' -+!10', 27 | '|' = ' -+!10', 28 | '&' = ' -+!10' 29 | ) %>% purrr::map(~rev(strsplit(.x, '')[[1]])) 30 | 31 | char_lengths <- next_char %>% 32 | purrr::map_int(length) %>% 33 | unique() 34 | 35 | 36 | gamma <- 1.3 37 | 38 | 39 | 40 | asciify <- function(jpeg_filename, gamma) { 41 | 42 | qimage <- list() 43 | 44 | 45 | 46 | image <- jpeg::readJPEG(jpeg_filename) 47 | 48 | 49 | if (length(dim(image))==3) { 50 | image <- image[,,2] 51 | } 52 | image <- image[c(T,F),] 53 | 54 | for (char_length in char_lengths) { 55 | probs <- seq(0, 1, length.out = char_length + 1) 56 | j <- image 57 | j[] <- findInterval(image, quantile(image, probs = probs^gamma), rightmost.closed = TRUE) 58 | qimage[[char_length]] <- j 59 | } 60 | 61 | 62 | select_next_char <- function(row, col, prev_char) { 63 | 64 | # What are the allowable next characters? 65 | available_chars <- next_char[[prev_char]] 66 | N <- length(available_chars) 67 | 68 | # Which quantised image should be used as the reference? 69 | this_qimage <- qimage[[N]] 70 | 71 | # What is the level/value at the current location 72 | level <- this_qimage[row, col] 73 | level <- min(level, N) 74 | 75 | available_chars[level] 76 | } 77 | 78 | prev_char <- '+' 79 | ascii <- image 80 | 81 | for (row in seq(nrow(image))) { 82 | for (col in seq(ncol(image))) { 83 | if (col == ncol(image)) { 84 | # If we're at the end of a row, must end in a + or - 85 | this_char <- '+' 86 | } else { 87 | # Otherwise choose a character based upon the previous one 88 | this_char <- select_next_char(row, col, prev_char) 89 | } 90 | ascii[row, col] <- this_char 91 | prev_char <- this_char 92 | } 93 | } 94 | 95 | 96 | ascii[nrow(ascii), ncol(ascii)] <- 0 97 | 98 | ascii <- paste( 99 | apply(ascii, 1, paste, collapse=''), 100 | collapse="\n" 101 | ) 102 | 103 | ascii 104 | } 105 | 106 | 107 | 108 | 109 | ascii <- asciify("/Users/tomazkastrun/Downloads/tk_2022.jpg", gamma=2.0) 110 | cat(ascii, "\n") 111 | 112 | write.csv(ascii,"/Users/tomazkastrun/Downloads/TK_personal_photo_2022.txt", row.names = FALSE) 113 | _ -------------------------------------------------------------------------------- /functions/AnalogClock.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Annoying useless analog clock 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #26 7 | # Created: September 14, 2021 8 | # Author: Tomaž Kaštrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | 12 | # Changelog: 13 | ########################################### 14 | 15 | require(grid) 16 | #install.packages("beepr") 17 | 18 | 19 | DrawClock <- function(hour, minute, second) { 20 | 21 | t <- seq(0, 2*pi, length=13)[-13] 22 | x <- cos(t) 23 | y <- sin(t) 24 | 25 | 26 | grid.newpage() 27 | pushViewport(dataViewport(x, y, gp=gpar(lwd=3))) 28 | 29 | # Clock background 30 | grid.circle(x=0, y=0, default="native", r=unit(1, "native")) 31 | 32 | # Hour hand 33 | hourAngle <- pi/2 - (hour + minute/60)/12*2*pi 34 | grid.segments(0, 0, 0.6*cos(hourAngle), .6*sin(hourAngle), default="native", gp=gpar(lex=4, col="red")) 35 | 36 | # Minute hand 37 | minuteAngle <- pi/2 - (minute)/60*2*pi 38 | grid.segments(0, 0, 0.8*cos(minuteAngle), .8*sin(minuteAngle),default="native", gp=gpar(lex=2)) 39 | 40 | # Second hand 41 | secondAngle <- pi/2 - (second)/60*2*pi 42 | grid.segments(0, 0, 43 | 0.8*cos(secondAngle), .7*sin(secondAngle), default="native", gp=gpar(lex=1, col = "blue"), draw=TRUE) 44 | grid.circle(0,0, default="native", r=unit(1, "mm"), gp=gpar(fill="white")) 45 | } 46 | 47 | 48 | 49 | AnalogClock <- function() { 50 | while(TRUE){ 51 | hh <- as.integer(format(Sys.time(), format="%H")) 52 | mm <- as.integer(format(Sys.time(), format="%M")) 53 | ss <- as.integer(format(Sys.time(), format="%S")) 54 | Sys.sleep(1) 55 | DrawClock(hh,mm,ss) 56 | beepr::beep(sound = 1, expr = NULL) 57 | } 58 | } 59 | 60 | #Run Function / clock 61 | AnalogClock() 62 | 63 | 64 | 65 | 66 | 67 | -------------------------------------------------------------------------------- /functions/Animate_dataset.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Animating dataset with simple gganimate 4 | # 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #36 8 | # Created: April 29, 2022 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | 13 | # Changelog: 14 | # 15 | ########################################### 16 | 17 | library(ggplot2) 18 | library(gganimate) 19 | library(ggthemes) 20 | 21 | 22 | ggplot(iris, aes(factor(Species), Sepal.Length, colour = Species)) + 23 | geom_boxplot(show.legend = FALSE) + 24 | labs(title = 'Petal width: {as.numeric(format(round(frame_time, 2), nsmall = 2))}', x= 'Iris species', y = 'Sepal Length') + 25 | # transition_time(as.numeric(Petal.Width)) + 26 | transition_time(as.numeric(Petal.Width)) + 27 | ease_aes('sine-in-out') + 28 | enter_fade() + 29 | theme_hc() 30 | 31 | 32 | -------------------------------------------------------------------------------- /functions/AnimatingProbabilityPlots.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Probability Plots 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #28 7 | # Created: November 11, 2021 8 | # Author: Tomaž Kaštrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | 12 | ########################################### 13 | 14 | distributions <- c("dbeta", "dbinom", "dcauchy", "dchisq", "dexp", "dgamma", "dgeom", "dhyper", 15 | "dlnorm", "dmultinom", "dnbinom", "dnorm", "dpois", "dt", "dunif", "dweibull", "wilcox", "logis", "hyper", "tukey") 16 | 17 | 18 | -------------------------------------------------------------------------------- /functions/AnscombeQuartet.R: -------------------------------------------------------------------------------- 1 | 2 | # Anscombe's Quartet 3 | 4 | library(ggplot2) 5 | library(grid) 6 | library(gridExtra) 7 | library(datasets) 8 | 9 | 10 | anscombe <- datasets::anscombe 11 | 12 | 13 | p1 <- ggplot(anscombe) + 14 | geom_point(aes(x1, y1), color = "darkorange", size = 1.5) + 15 | scale_x_continuous(breaks = seq(0,20,2)) + 16 | scale_y_continuous(breaks = seq(0,12,2)) + 17 | expand_limits(x = 0, y = 0) + 18 | labs(x = "x1", y = "y1", 19 | title = "Dataset 1" ) + 20 | theme_bw() 21 | p1 22 | 23 | 24 | p2 <- ggplot(anscombe) + 25 | geom_point(aes(x2, y2), color = "darkorange", size = 1.5) + 26 | scale_x_continuous(breaks = seq(0,20,2)) + 27 | scale_y_continuous(breaks = seq(0,12,2)) + 28 | expand_limits(x = 0, y = 0) + 29 | labs(x = "x2", y = "y2", 30 | title = "Dataset 2" ) + 31 | theme_bw() 32 | p2 33 | 34 | 35 | p3 <- ggplot(anscombe) + 36 | geom_point(aes(x3, y3), color = "darkorange", size = 1.5) + 37 | scale_x_continuous(breaks = seq(0,20,2)) + 38 | scale_y_continuous(breaks = seq(0,12,2)) + 39 | expand_limits(x = 0, y = 0) + 40 | labs(x = "x3", y = "y3", 41 | title = "Dataset 3" ) + 42 | theme_bw() 43 | p3 44 | 45 | p4 <- ggplot(anscombe) + 46 | geom_point(aes(x4, y4), color = "darkorange", size = 1.5) + 47 | scale_x_continuous(breaks = seq(0,20,2)) + 48 | scale_y_continuous(breaks = seq(0,12,2)) + 49 | expand_limits(x = 0, y = 0) + 50 | labs(x = "x4", y = "y4", 51 | title = "Dataset 4" ) + 52 | theme_bw() 53 | p4 54 | 55 | 56 | grid.arrange(grobs = list(p1, p2, p3, p4), 57 | ncol = 2, 58 | top = "Anscombe's Quartet") 59 | 60 | 61 | 62 | p1_fitted <- p1 + geom_abline(intercept = 3.0001, slope = 0.5001, color = "blue") 63 | p2_fitted <- p2 + geom_abline(intercept = 3.001, slope = 0.500, color = "blue") 64 | p3_fitted <- p3 + geom_abline(intercept = 3.0025, slope = 0.4997, color = "blue") 65 | p4_fitted <- p4 + geom_abline(intercept = 3.0017, slope = 0.499, color = "blue") 66 | 67 | grid.arrange(grobs = list(p1_fitted, p2_fitted, 68 | p3_fitted, p4_fitted), 69 | ncol = 2, 70 | top = "Anscombe's Quartet") -------------------------------------------------------------------------------- /functions/Benchmark_test.R: -------------------------------------------------------------------------------- 1 | 2 | ########################################## 3 | # 4 | # Benchmarking vectors and data.frames 5 | # on simple MapReduce problem 6 | # 7 | # Series: 8 | # Little Useless-useful R functions #35 9 | # Created: March 21, 2022 10 | # Author: Tomaz Kastrun 11 | # Blog: tomaztsql.wordpress.com 12 | # V.1.0 13 | 14 | # Changelog: 15 | # 16 | ########################################### 17 | 18 | 19 | library(rbenchmark) 20 | library(purrr) 21 | library(dplyr) 22 | 23 | len <- 10000000 # 10^6 24 | lett <- c(LETTERS[1:20]) 25 | 26 | set.seed(2908) 27 | a_vec <- do.call(paste0, c(as.list(sample(lett,len,replace=TRUE)), sep="")) # a vector 28 | 29 | a_df <- data.frame(chr = paste0(sample(lett,len,replace=TRUE), sep="")) # a data frame 30 | 31 | 32 | rbenchmark::benchmark( 33 | "table with vector" = { 34 | res_table <- "" 35 | a_table <- table(strsplit(a_vec, "")) 36 | for (i in 1:length(names(a_table))) { 37 | key<- (names(a_table[i])) 38 | val<-(a_table[i]) 39 | res_table <- paste0(res_table,key,val) 40 | } 41 | }, 42 | "dplyr with data.frame" = { 43 | 44 | res_dplyr <- a_df %>% 45 | count(chr, sort=TRUE) %>% 46 | mutate(res = paste0(chr, n, collapse = "")) %>% 47 | select(-chr, -n) %>% 48 | group_by(res) 49 | 50 | res_dplyr[1,] 51 | 52 | 53 | }, 54 | "purrr with data.frame" = { 55 | adf_table <- a_df %>% 56 | map(~count(data.frame(x=.x), x)) 57 | 58 | res_purrr <- "" 59 | for (i in 1:nrow(adf_table$chr)) { 60 | key<- adf_table$chr[[1]][i] 61 | val<- adf_table$chr[[2]][i] 62 | res_purrr <- paste0(res_purrr,key,val) 63 | } 64 | 65 | }, 66 | replications = 20, order = "relative" 67 | ) 68 | 69 | 70 | 71 | 72 | 73 | -------------------------------------------------------------------------------- /functions/BigDigitalClock.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Annoying useless big digital clock 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #27 7 | # Created: September 15, 2021 8 | # Author: Tomaž Kaštrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | 12 | # Changelog: 13 | ########################################### 14 | 15 | 16 | # Create Numbers 17 | n0 <- 18 | c("██████" 19 | ,"██ ██" 20 | ,"██ ██" 21 | ,"██ ██" 22 | ,"██████") 23 | 24 | n1 <- 25 | c(" ██" 26 | ," ██" 27 | ," ██" 28 | ," ██" 29 | ," ██") 30 | 31 | n2 <- 32 | c("██████" 33 | ," ██" 34 | ,"██████" 35 | ,"██ " 36 | ,"██████") 37 | 38 | n3 <- 39 | c("██████" 40 | ," ██" 41 | ,"██████" 42 | ," ██" 43 | ,"██████") 44 | 45 | n4 <- 46 | c("██ ██" 47 | ,"██ ██" 48 | ,"██████" 49 | ," ██" 50 | ," ██") 51 | 52 | n5 <- 53 | c("██████" 54 | ,"██ " 55 | ,"██████" 56 | ," ██" 57 | ,"██████") 58 | 59 | n6 <- 60 | c("██████" 61 | ,"██ " 62 | ,"██████" 63 | ,"██ ██" 64 | ,"██████") 65 | 66 | n7 <- 67 | c("██████" 68 | ," ██" 69 | ," ██" 70 | ," ██" 71 | ," ██") 72 | 73 | n8 <- 74 | c("██████" 75 | ,"██ ██" 76 | ,"██████" 77 | ,"██ ██" 78 | ,"██████") 79 | 80 | n9 <- 81 | c("██████" 82 | ,"██ ██" 83 | ,"██████" 84 | ," ██" 85 | ,"██████") 86 | 87 | colon <- 88 | c(" " 89 | ," ██ " 90 | ," " 91 | ," ██ " 92 | ," ") 93 | 94 | df0 <- as.data.frame(n0) 95 | df1 <- as.data.frame(n1) 96 | df2 <- as.data.frame(n2) 97 | df3 <- as.data.frame(n3) 98 | df4 <- as.data.frame(n4) 99 | df5 <- as.data.frame(n5) 100 | df6 <- as.data.frame(n6) 101 | df7 <- as.data.frame(n7) 102 | df8 <- as.data.frame(n8) 103 | df9 <- as.data.frame(n9) 104 | dfc <- as.data.frame(colon) 105 | 106 | numbers <- cbind(df0, df1,df2,df3,df4,df5,df6,df7,df8,df9, dfc) 107 | rm(df0, df1,df2,df3,df4,df5,df6,df7,df8,df9, dfc,n0,n1,n2,n3,n4,n5,n6,n7,n8,n9, colon) 108 | 109 | # Get number / variable from data frame 110 | getVariable <- function(x) { 111 | stopifnot(is.numeric(x)) 112 | if (x == 0) {return (numbers$n0)} 113 | if (x == 1) {return (numbers$n1)} 114 | if (x == 2) {return (numbers$n2)} 115 | if (x == 3) {return (numbers$n3)} 116 | if (x == 4) {return (numbers$n4)} 117 | if (x == 5) {return (numbers$n5)} 118 | if (x == 6) {return (numbers$n6)} 119 | if (x == 7) {return (numbers$n7)} 120 | if (x == 8) {return (numbers$n8)} 121 | if (x == 9) {return (numbers$n9)} 122 | } 123 | 124 | 125 | BigDitigalClock <- function() { 126 | 127 | while(TRUE){ 128 | Sys.sleep(1) 129 | cat("\014") 130 | 131 | #hour 132 | h1 <- substr(strftime(Sys.time(), format="%H"),1,1) 133 | h2 <- substr(strftime(Sys.time(), format="%H"),2,2) 134 | 135 | #minute 136 | m1 <- substr(strftime(Sys.time(), format="%M"),1,1) 137 | m2 <- substr(strftime(Sys.time(), format="%M"),2,2) 138 | 139 | #second 140 | s1 <- substr(strftime(Sys.time(), format="%S"),1,1) 141 | s2 <- substr(strftime(Sys.time(), format="%S"),2,2) 142 | 143 | dfh1 <- as.data.frame(getVariable(as.integer(h1))) 144 | dfh2 <- as.data.frame(getVariable(as.integer(h2))) 145 | dfm1 <- as.data.frame(getVariable(as.integer(m1))) 146 | dfm2 <- as.data.frame(getVariable(as.integer(m2))) 147 | dfs1 <- as.data.frame(getVariable(as.integer(s1))) 148 | dfs2 <- as.data.frame(getVariable(as.integer(s2))) 149 | 150 | current_time <- cbind(dfh1, dfh2, numbers$colon, 151 | dfm1, dfm2 , numbers$colon, 152 | dfs1, dfs2) 153 | 154 | #Remove column namens and row names 155 | colnames(current_time) <- c(" "," "," "," "," "," "," "," ") 156 | print.data.frame(current_time, row.names = F) 157 | } 158 | } 159 | 160 | # Run the clock 161 | BigDitigalClock() 162 | -------------------------------------------------------------------------------- /functions/Bionic_Reading.R: -------------------------------------------------------------------------------- 1 | 2 | ########################################## 3 | # 4 | # Reading faster with Bionic Reading 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #56 8 | # Created: October 07, 2023 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | 13 | # Changelog: 14 | ########################################### 15 | 16 | 17 | 18 | sample_text <- " 19 | Bionic Reading is a new method 20 | facilitating the reading process 21 | by guiding the eyes through 22 | text with artificial fixation points. 23 | 24 | As a result, the reader is only 25 | focusing on the highlighted 26 | initial letters and lets the brain 27 | center complete the word. 28 | 29 | In a digital world dominated 30 | by shallow forms of reading, 31 | Bionic Reading aims to 32 | encourage a more in-depth 33 | reading and understanding 34 | of written content. 35 | " 36 | 37 | 38 | Make_text_easier_to_read <- function(input_text){ 39 | 40 | bold <- "\033[1m" 41 | underline <- "\033[4m" 42 | reset <- "\033[0m" 43 | blue <- "\033[34m" 44 | 45 | modify_word <- function(word) { 46 | word_length <- nchar(word) 47 | first_half <- substr(word, 1, ceiling(word_length / 2)) 48 | first_half_bold <- paste0(bold, first_half, reset) 49 | second_half <- substr(word, ceiling(word_length / 2)+1, word_length) 50 | second_half_bold <- paste0(blue, second_half, reset) 51 | final_word <- paste0(first_half_bold, second_half_bold) 52 | return(final_word) 53 | } 54 | 55 | words <- unlist(strsplit(sample_text, " ")) 56 | modified_words <- sapply(words, modify_word) 57 | formatted_text <- paste(modified_words, collapse = " ") 58 | cat(formatted_text, "\n") 59 | } 60 | 61 | 62 | 63 | 64 | #simple text 65 | cat("\033[34m", sample_text, "\033[0m", "\n") 66 | 67 | # run the function 68 | Make_text_easier_to_read(sample_text) 69 | 70 | 71 | 72 | 73 | 74 | -------------------------------------------------------------------------------- /functions/BrierScore.R: -------------------------------------------------------------------------------- 1 | ## Brier score 2 | 3 | fit <- glm(am~hp+wt,data=mtcars,family='binomial') 4 | 5 | library(ggplot2) 6 | ggplot(mtcars, aes(x=hp, y=wt), label=Name) + geom_point(aes(color=am)) + geom_smooth() + 7 | geom_text(aes(label=as.character(Name),hjust=0,vjust=0)) 8 | 9 | 10 | pred.prob <- predict(fit,type='response') 11 | brierScore <- mean((pred.prob-mtcars$am)^2) 12 | # 0.04659236 13 | 14 | #mock data 15 | ld <- rep(0:5, 2) 16 | nun <- c(1, 4, 9, 13, 18, 20, 0, 2, 6, 10, 12, 16) 17 | s <- factor(rep(c("M", "F"), c(6, 6))) 18 | sf <- cbind(nun, nuna = 20 - nun) 19 | 20 | # Run a model 21 | bu<- glm(sf ~ s + ld - 1, family = "binomial") 22 | # Brier score 23 | 24 | mean(bu$residuals^2) 25 | ## 0.2848604 26 | 27 | -------------------------------------------------------------------------------- /functions/Call_StatsfunR.R: -------------------------------------------------------------------------------- 1 | pcks_4_install <- c("ggplot2", "leaflet", "plotly", "tidyverse") 2 | install.packages(pcks_4_install, dependencies = TRUE) 3 | lapply(pcks_4_install, library, character.only = TRUE) 4 | 5 | 6 | 7 | getwd() 8 | setwd("/Users/tomazkastrun/Documents/tomaztk_github/Useless_R_functions/functions") 9 | 10 | source("Stats_fun.R") 11 | 12 | 13 | groupsum(mtcars,"cyl", "hp") 14 | 15 | 16 | plot_sorted_scatter(mtcars, 'hp', 'brand') 17 | -------------------------------------------------------------------------------- /functions/Catalan_number.R: -------------------------------------------------------------------------------- 1 | ##################### 2 | ## Catalan number ### 3 | ##################### 4 | 5 | library(ggplot2) 6 | library(tidyverse) 7 | 8 | # Function for factorial 9 | factorial <- function(n) { 10 | if (n == 0) { 11 | return(1) 12 | } else { 13 | return(n * factorial(n - 1)) 14 | } 15 | } 16 | 17 | # Function for n-th Catalan number 18 | catalan <- function(n) { 19 | if (n == 0) { 20 | return(1) 21 | } else { 22 | return(factorial(2 * n) / (factorial(n + 1) * factorial(n))) 23 | } 24 | } 25 | 26 | 27 | 28 | for (i in 0:10) { 29 | cat(sprintf("fun(%d) = %d\n", i, factorial(i))) 30 | } 31 | 32 | 33 | # Draw graph 34 | df <- as.data.frame(NULL) 35 | for (i in 0:12) { 36 | df_i <- print(i) 37 | cat_i <- catalan(i) 38 | fac_i <- factorial(i) 39 | df <- rbind(df, c(df_i, cat_i, fac_i)) 40 | } 41 | 42 | colnames(df) <- c("i", "catalan", "factorial") 43 | 44 | df$i <- as.integer(df$i) 45 | df$catalan <- as.integer(df$catalan) 46 | df$factorial <- as.integer(df$factorial) 47 | df$factorialLog <- log(df$factorial) 48 | df$catalanLog <- log(df$catalan) 49 | 50 | 51 | ggplot(df, aes(x=i)) + 52 | geom_line(aes(y = catalan), color = "darkgreen") + 53 | geom_line(aes(y = factorial), color="steelblue") 54 | 55 | 56 | # or 57 | df %>% 58 | select(i, catalan, factorial) %>% 59 | gather(key = "variable", value = "value", -i) %>% 60 | ggplot(aes(x = i, y = value)) + 61 | geom_line(aes(color = variable, linetype = variable)) + 62 | scale_color_manual(values = c("darkgreen", "steelblue")) 63 | 64 | 65 | 66 | # or with log 67 | df %>% 68 | select(i, catalanLog, factorialLog) %>% 69 | gather(key = "variable", value = "value", -i) %>% 70 | ggplot(aes(x = i, y = value)) + 71 | geom_line(aes(color = variable, linetype = variable)) + 72 | scale_color_manual(values = c("darkgreen", "steelblue")) 73 | 74 | 75 | 76 | 77 | -------------------------------------------------------------------------------- /functions/Chicken_egg_problem.R: -------------------------------------------------------------------------------- 1 | # what came first the chicken or the egg? 2 | # 🥚 Egg 3 | # 🐔 Chicken 4 | 5 | whatcamefirst <- c("🥚","🐔" ) 6 | r <- sort(whatcamefirst, decreasing = FALSE) 7 | r 8 | #> [1] "🐔" "🥚" 9 | is.unsorted(r) 10 | #> [1] FALSE -------------------------------------------------------------------------------- /functions/Cognitive Bias.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Generating cognitive bias for all the 4 | # hard-core psychologists :) and 5 | # visualize the graph network 6 | # 7 | # Series: 8 | # Little Useless-useful R functions #71 9 | # Created: May 12, 2025 10 | # Author: Tomaz Kastrun 11 | # Blog: tomaztsql.wordpress.com 12 | 13 | # ToDo: 14 | # get more sense to the useless function 15 | # more samples from the psychology 16 | 17 | ########################################### 18 | 19 | library(igraph) 20 | library(ggraph) 21 | library(ggplot2) 22 | 23 | bias_explorer <- function(seed = 2908, n_links = 25) { 24 | set.seed(seed) 25 | 26 | # Some psych effects from RL 27 | biases <- c( 28 | "Confirmation Bias", "Anchoring Bias", "Availability Heuristic", 29 | "Dunning-Kruger Effect", "Survivorship Bias", "Recency Bias", 30 | "Sunk Cost Fallacy", "Bandwagon Effect", "Framing Effect", 31 | "Self-Serving Bias", "Negativity Bias", "Halo Effect" 32 | ) 33 | 34 | # useless links :) 35 | weird_links <- c( 36 | "You saw it on Reddit", "Too lazy to verify", "Sounds familiar", 37 | "Because Elon tweeted it", "Grandma said so", "Wikipedia said maybe", 38 | "Your gut feeling", "Cited by no one", "Used in a TED talk", 39 | "Found in fortune cookie", "Might be science", "Feels statistically valid" 40 | ) 41 | 42 | edges <- data.frame( 43 | from = sample(biases, n_links, replace = TRUE), 44 | to = sample(biases, n_links, replace = TRUE), 45 | reason = sample(weird_links, n_links, replace = TRUE), 46 | stringsAsFactors = FALSE 47 | ) 48 | 49 | edges <- edges[edges$from != edges$to, ] 50 | g <- graph_from_data_frame(edges, vertices = data.frame(name = biases), directed = TRUE) 51 | 52 | ggraph(g, layout = "drl") + 53 | geom_edge_link( 54 | aes(label = reason), 55 | arrow = arrow(length = unit(3, 'mm')), 56 | end_cap = circle(2, 'mm'), 57 | start_cap = circle(2, 'mm'), 58 | label_colour = "darkgray", 59 | edge_width = 1.2, 60 | colour = "skyblue" 61 | ) + 62 | geom_node_point(color = "darkred", size = 6) + 63 | geom_node_text(aes(label = name), repel = TRUE, fontface = "bold", size = 3.5) + 64 | labs( 65 | title = "Bias_explorer(): The Absurd Web of Biases", 66 | subtitle = "Visualizing ridiculous mental shortcuts.", 67 | caption = "Edges represent irrational and useless connections." 68 | ) + 69 | theme_void() 70 | 71 | } 72 | 73 | ################## 74 | # Run the function 75 | ################## 76 | 77 | bias_explorer() 78 | -------------------------------------------------------------------------------- /functions/ColorfulPlot.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Colourful line graph with ggplot 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #27 7 | # Created: July 14, 2021 8 | # Author: Tomaž Kaštrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | 12 | # Changelog: 13 | ########################################### 14 | 15 | library(ggplot2) 16 | library(RColorBrewer) 17 | 18 | 19 | ## generating fake dataset (x,y) points for a single line 20 | set.seed(29038) 21 | 22 | #The function 23 | Colourful_graph <- function(n, x, y){ 24 | df <- data.frame(x=x, y=y, col=n) 25 | for (i in 1:n){ 26 | #get last x,y 27 | lastx <- tail(df$x, 1) 28 | lasty <- tail(df$y, 1) 29 | col <- sample(1:i, 1, replace = T) 30 | if (i %% 10 == 0) { 31 | xx <- runif(1, 0.0, 1.0) + lastx 32 | yy <- runif(1, 0.0, 1.0) - lasty 33 | } else { 34 | xx <- runif(1, 0.0, 1.0) + lastx 35 | yy <- runif(1, 0.0, 1.0) - lasty 36 | } 37 | # change: col=i for rainbow colours 38 | df <- rbind(df, c(x=xx, y=yy, col=col)) 39 | 40 | } 41 | fake <- df 42 | 43 | #brewer sample 8 color palette 44 | nn <- as.data.frame(brewer.pal.info) 45 | nn$names <- row.names.data.frame(nn) 46 | nn8 <- subset(nn, maxcolors==8, select=c(names)) 47 | 48 | 49 | brewColours <- as.integer(length(fake$col)) 50 | #ColourfulColours <- colorRampPalette(brewer.pal(8, "Paired"))(brewColours) 51 | ColourfulColours <- colorRampPalette(brewer.pal(8, sample(nn8$names,1,T)))(brewColours) 52 | 53 | # show faked graph 54 | ggplot(fake, aes(x, y, color = factor(col))) + 55 | geom_line(color= ColourfulColours) + 56 | theme(legend.position = "none") + 57 | theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank(), 58 | panel.background = element_blank(), axis.line = element_blank(), text=element_blank(), line = element_blank()) 59 | 60 | } 61 | 62 | 63 | 64 | #create colourful graph 65 | Colourful_graph(500,0.4,0.3) 66 | 67 | 68 | 69 | -------------------------------------------------------------------------------- /functions/Concurrency_simulations.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Running concurrent simulations 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #24 7 | # Created: June 4, 2021 8 | # Author: Tomaž Kaštrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | 12 | # Changelog: 13 | ########################################### 14 | 15 | 16 | computelinks <- function(links){ 17 | nr <- nrow(links) 18 | nc <- ncol(links) 19 | tot <- 0 20 | for (i in 1:(nr-1)) { 21 | for (j in (i+1):nr) { 22 | for (k in 1:nc) 23 | tot <- tot + links[i,k] * links[j,k] 24 | } 25 | } 26 | r <- tot/(nr*(nr-1)/2) 27 | print(r) 28 | } 29 | 30 | 31 | ## Optimised version 32 | computelinks_fast <- function(links){ 33 | nr <- nrow(links) 34 | nc <- ncol(links) 35 | tot <- 0 36 | for (i in 1:(nr-1)) { 37 | tmp <- links[(i+1):nr,] %*% links[i,] 38 | tot <- tot + sum(tmp) 39 | } 40 | 41 | r <- tot/(nr *(nr-1)/2) 42 | print(r) 43 | } 44 | 45 | 46 | sim_Fast <- function(mat){ 47 | print(system.time(computelinks_fast(mat))) 48 | } 49 | 50 | sim_Slow <- function(mat){ 51 | system.time(computelinks(mat)) 52 | } 53 | 54 | ################################### 55 | ### Comparison of both calculations 56 | ################################### 57 | 58 | # will produce same end results; different timings 59 | nr <- 500 60 | nc <- 500 61 | cal <- matrix(sample(0:1, (nr*nc), replace=TRUE), nrow=nr) 62 | 63 | 64 | sim_Slow(cal) 65 | sim_Fast(cal) 66 | 67 | 68 | ################################### 69 | ### Library parallel 70 | ### WIP with same calculations 71 | ################################### 72 | 73 | # install.packages("parallel") 74 | library(parallel) 75 | 76 | doichunk <- function (ichunk) { 77 | tot <- 0 78 | nr <- nrow(lnks) 79 | for (i in ichunk) { 80 | tmp <- lnks[(i+1):nr,] %∗% lnks[i,] 81 | tot <- tot + sum(tmp) 82 | } 83 | return(tot) 84 | } 85 | 86 | mutoutpar <- function(cls,lnks) { 87 | nr <- nrow(lnks) 88 | clusterExport(cls, "lnks") 89 | ichunks <- 1:(nr-1) 90 | tots <- clusterApply(cls, ichunks, doichunk) 91 | Reduce(sum,tots)/nr 92 | } 93 | 94 | nworkers <- #integer 95 | makeCluster(nworkers) 96 | -------------------------------------------------------------------------------- /functions/Convert_text_to_numbers.R: -------------------------------------------------------------------------------- 1 | 2 | ########################################## 3 | # 4 | # 5 | # Old phone converted from text to numbers 6 | # and from numbers to text 7 | # 8 | # Series: 9 | # Little Useless-useful R functions #51 10 | # Created: May 01, 2023 11 | # Author: Tomaz Kastrun 12 | # Blog: tomaztsql.wordpress.com 13 | # V.1.0 14 | # 15 | # Changelog: 16 | # 17 | ########################################## 18 | 19 | #helper data 20 | let <- c("a","b","c","", 21 | "d","e","f","", 22 | "g","h","i","", 23 | "j","k","l","", 24 | "m","n","o","", 25 | "p","q","r","s", 26 | "t","u","v","", 27 | "w","x","y","z") 28 | 29 | mm <- matrix(let, nrow = 8, ncol=4, byrow = TRUE, 30 | dimnames = list( 31 | c("N2","N3","N4","N5","N6","N7","N8","N9"), 32 | c("P.1","P.2","P.3","P.4")) 33 | ) 34 | 35 | 36 | 37 | # function test 38 | 39 | SMSconverter("text") 40 | SMSconverter("833998") 41 | -------------------------------------------------------------------------------- /functions/DataFrameMaker.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Random Data-frame maker 4 | # Series: 5 | # Little Useless-useful R functions #2 6 | # Created: October 19, 2020 7 | # Author: Tomaž Kaštrun 8 | # Blog: tomaztsql.wordpress.com 9 | # V.1.0 10 | 11 | # Changelog: 12 | ########################################### 13 | 14 | 15 | 16 | ##################################### 17 | ##### 18 | ##### Using Structure function 19 | ##### 20 | ##################################### 21 | 22 | DataFrameMaker <- function(col,row){ 23 | command = "dd <- structure(list( " 24 | for (i in 1:col){ 25 | var = paste("v",as.character(i),"= c(",sep="") 26 | command = paste(command, var ,sep = "") 27 | for (j in 1:row){ 28 | a <- c(i*j) 29 | con = paste(a,sep="") 30 | if ((j < row) & (j %% row != 0)){ 31 | command = paste(command, con,",",sep = "") 32 | } 33 | else { 34 | command = paste(command, con,"), ",sep = "") 35 | } 36 | } 37 | 38 | } 39 | rn = 'row.names = c(' 40 | for(xx in 1:row){ 41 | rn = paste(rn, xx, 'L,', sep = "") 42 | if (xx == row){rn = paste(substr(rn,1,nchar(rn)-1),')', sep = "")} 43 | } 44 | 45 | command <- substr(command, 1, nchar(command)-2) 46 | command <- paste(command,"),", rn, "," ,"class = 'data.frame')",sep = "") 47 | print(command) 48 | eval(parse(text=command)) 49 | } 50 | 51 | 52 | # Run the dataframe 53 | DataFrameMaker(4,2) 54 | 55 | 56 | 57 | 58 | ##################################### 59 | ##### 60 | ##### Using Structure function 61 | ##### 62 | #################################### 63 | 64 | DataFrameMaker <- function(col,row){ 65 | dd <- matrix(nrow = row, ncol = col) 66 | for (i in 1:row) { 67 | for (j in 1:col) { 68 | dd[i, j] = (j*i) 69 | } 70 | } 71 | return(as.data.frame(dd)) 72 | 73 | } 74 | 75 | # Run the dataframe 76 | dd <- DataFrameMaker(4,2) 77 | 78 | 79 | ##################################### 80 | ##### 81 | ##### Making Use of vector datatypes 82 | ##### 83 | #################################### 84 | 85 | DataFrameMaker <- function(i, j) { 86 | v1 <- rep(1:i, j) 87 | v2 <- rep(1:j, i) 88 | m1 <- matrix(v1, ncol = j, byrow = FALSE) 89 | m2 <- matrix(v2, ncol = j, byrow = TRUE) 90 | as.data.frame(m1 * m2) 91 | } 92 | 93 | 94 | ##################################### 95 | ##### 96 | ##### Using Kronecker products on Arrays 97 | ##### 98 | ##### Contributed by Brad: https://tomaztsql.wordpress.com/2020/10/20/little-useless-useful-r-function-dataframe-maker/#comments 99 | ##### 100 | #################################### 101 | 102 | DataFrameMaker <- function(nrow, ncol) { 103 | dd <- as.data.frame(kronecker(1:nrow,t(1:ncol))) 104 | return(dd) 105 | } 106 | 107 | DataFrameMaker(3,4) 108 | -------------------------------------------------------------------------------- /functions/Dataframe_to_markdown.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # create markdown table based on dataframe 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #51 7 | # Created: March 23, 2023 8 | # Author: Tomaz Kastrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | 12 | # Changelog: 13 | # 14 | ########################################### 15 | 16 | 17 | # > iris[1:3,1:5] 18 | # Result: 19 | #> Sepal.Length Sepal.Width Petal.Length Petal.Width Species 20 | #> 1 5.1 3.5 1.4 0.2 setosa 21 | #> 2 4.9 3.0 1.4 0.2 setosa 22 | #> 3 4.7 3.2 1.3 0.2 setosa 23 | 24 | # Create function that will return a markdown script of table with 25 | # data, ready for Markdown document: 26 | 27 | #> |Sepal.Length|Sepal.Width|Petal.Length|Petal.Width|Species| 28 | #> |---|---|---|---|---| 29 | #> |5.1|3.5|1.4|0.2|setosa| 30 | #> |4.9|3|1.4|0.2|setosa| 31 | #> |4.7|3.2|1.3|0.2|setosa| 32 | 33 | 34 | df_2_MD <- function(your_df){ 35 | 36 | cn <- as.character(names(your_df)) 37 | headr <- paste0(c("", cn), sep = "|", collapse='') 38 | sepr <- paste0(c('|', rep(paste0(c(rep('-',3), "|"), collapse=''),length(cn))), collapse ='') 39 | st <- "|" 40 | for (i in 1:nrow(your_df)){ 41 | for(j in 1:ncol(your_df)){ 42 | if (j%%ncol(your_df) == 0) { 43 | st <- paste0(st, as.character(your_df[i,j]), "|", "\n", "" , "|", collapse = '') 44 | } else { 45 | st <- paste0(st, as.character(your_df[i,j]), "|", collapse = '') 46 | } 47 | } 48 | } 49 | fin <- paste0(c(headr, sepr, substr(st,1,nchar(st)-1)), collapse="\n") 50 | cat(fin) 51 | } 52 | 53 | 54 | 55 | #subset 56 | short_iris <- iris[1:3,1:5] 57 | 58 | # run function 59 | df_2_MD(short_iris) 60 | df_2_MD(iris) 61 | 62 | 63 | -------------------------------------------------------------------------------- /functions/DrawFunctionCodeOnConsole.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Draw function on console plot with code 4 | # Series: 5 | # Little Useless-useful R functions #7 6 | # Created: November 1, 2020 - work in prog 7 | # Author: Tomaz Kastrun 8 | # Blog: tomaztsql.wordpress.com 9 | # V.1.0 10 | 11 | # Changelog: 12 | # - adding new functions 13 | ########################################### 14 | 15 | 16 | # random text, later to be coode 17 | tkt <- "to je tole, pa takole je, ker tako je in sicer ne bi tako bilo, ker tako je in pika. Tako gre, ker tako je in sicer ne more tako, ker je kot ni in pika." 18 | 19 | 20 | 21 | ##### 1. Rectangle 22 | 23 | draw_rect <- function(size, codetext) { 24 | r <- nchar(codetext) 25 | #s <- ceiling(sqrt(r)) 26 | x = size 27 | y = floor(r/x) 28 | for (i in 1:y){ 29 | if (i == 1){ 30 | cat( paste0("#",substr(codetext,1, size),"#","\n" )) 31 | } else { 32 | cat( paste0("#",substr(codetext,1+(size*i), size+(size*i)),"#","\n" )) 33 | } 34 | } 35 | } 36 | 37 | #test 38 | draw_rect(10,tkt) 39 | 40 | 41 | 42 | ##### 1. Parallelogram 43 | draw_parallel <- function(h, codetext){ 44 | r <- nchar(codetext) 45 | a = ceiling(sqrt(r*4/1.73)) 46 | v = ceiling(r/a) + h 47 | for (i in 1:v){ 48 | if (i == 1){ 49 | cat( paste0(paste0(replicate(i,"\n "), collapse=""),substr(codetext,1, a),paste0(replicate(i,"\n "), collapse=""))) 50 | } else { 51 | cat( paste0(paste0(replicate(i," "), collapse=""),substr(codetext,1+(a*i)-i, a+(a*i)-i),paste0(replicate(i," "), collapse=""),"\n" )) 52 | } 53 | } 54 | } 55 | 56 | 57 | #test 58 | draw_parallel(10,tkt) 59 | 60 | 61 | 62 | draw_triang <- function(h, codetext){ 63 | r <- nchar(codetext) 64 | a = ceiling(sqrt(r*4/1.73)) 65 | v = ceiling(r/a) + h 66 | for (i in 1:v){ 67 | presledek = i*2 68 | cat( paste0(paste0(strrep(" ",presledek/2), collapse =""), substr(codetext,1,a-presledek), paste0(replicate(presledek/2, " "), collapse = ""), "\n")) 69 | } 70 | } 71 | 72 | draw_triang(10, tkt) 73 | 74 | 75 | 76 | 77 | draw_tann <- function(s, codetext){ 78 | for (i in 1:s){ 79 | print(i) 80 | ll <- nchar(codetext) 81 | div <- floor(ll/s) 82 | for (l in 1:div){ 83 | print(substring(codetext,i*l, i*div)) 84 | } 85 | } 86 | } 87 | 88 | draw_tann(10, tkt) 89 | 90 | 91 | 92 | 93 | draw_circle <- function( 94 | diameter = 5, 95 | rows = 6, 96 | codetext=tkt){ 97 | vectT <- seq(0,2*pi, length.out = 10) 98 | r <- diameter/2 99 | nr <- nchar(codetext) 100 | a = ceiling(sqrt(nr*4/1.73)) 101 | dfa <- data.frame(NULL) 102 | for (i in 1:rows){ 103 | x_pos <- ceiling(i[1] + r * cos(vectT)) 104 | dfa <- rbind(dfa,as.data.frame((t(x_pos)))) 105 | } 106 | odmik <- dfa[1,] 107 | max_le <- max(dfa[,1]) 108 | for (i in 1:max_le){ 109 | if (i == 1){ 110 | print( paste0(paste0(replicate(as.integer(odmik[i])," "), collapse=""),substr(codetext,1, a),paste0(replicate(as.integer(odmik[i])," "), collapse=""))) 111 | } else { 112 | print( paste0(paste0(replicate(as.integer(odmik[i])," "), collapse=""),substr(codetext,1+(a*i)-i, a+(a*i)-i),paste0(replicate(as.integer(odmik[i])," "), collapse="") )) 113 | } 114 | } 115 | } 116 | 117 | 118 | 119 | draw_circle(9,6, tkt) 120 | 121 | 122 | 123 | 124 | draw_shape <- function(fun, size, codetext){ 125 | 126 | fun <- c("cos", "sin", "x", "x2", "x3", "xn") 127 | 128 | } 129 | 130 | 131 | -------------------------------------------------------------------------------- /functions/Drawing_Recursions.R: -------------------------------------------------------------------------------- 1 | 2 | ################################## 3 | ### 4 | ### Drawing recursion with ggplot2 5 | ### 6 | ################################## 7 | 8 | library(ggplot2) 9 | 10 | # function for circle 11 | 12 | circle <- function(center=c(1,1),rr = 4, p = 100){ 13 | r = rr / 2 14 | tt <- seq(0,2*pi,length.out = p) 15 | xx <- center[1] + r * cos(tt) 16 | yy <- center[2] + r * sin(tt) 17 | return(data.frame(x = xx, y = yy)) 18 | } 19 | 20 | 21 | df = data.frame(x = xx, y = yy) 22 | df2 = data.frame(x = xx, y = yy) 23 | df$g <- "1" 24 | df2$g <- "2" 25 | dd <- rbind(df, df2) 26 | 27 | 28 | ggplot(dd, aes(x,y)) + geom_path() 29 | ggplot(circle(c(-1,1),rr=1),aes(x,y)) + geom_path() + theme_minimal() 30 | 31 | 32 | 33 | drawCircle <- function(x,y,d,step){ 34 | while (step >= 0){ 35 | #drawCircle(x+20,y,d-0.1,step-1) 36 | x = x + 20 37 | y = y + 10 38 | d =d - 0.1 39 | step = step - 1 40 | # p <- ggplot(circle(c(x,y),rr=d),aes(x,y)) + geom_path() + theme_minimal() 41 | # p <- p + ggplot(circle(c(x,y),rr=d),aes(x,y)) + geom_path() + theme_minimal() 42 | } 43 | print(p) 44 | } 45 | 46 | 47 | drawCircle(-1,1,1,3) 48 | 49 | -------------------------------------------------------------------------------- /functions/DynamicVariableInString.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Inserting variable values into strings 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #25 7 | # Created: July 2, 2021 8 | # Author: Tomaž Kaštrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | # 12 | # Changelog: 13 | ########################################### 14 | 15 | vv <- "tomaz" 16 | 17 | #function 18 | cat_v <- function(tex){ 19 | rr <- " " 20 | pos_1 <- which(strsplit(tex, "")[[1]]=="{") 21 | pos_2 <- which(strsplit(tex, "")[[1]]=="}") 22 | end_pos <- nchar(tex) 23 | varname <- substr(tex, pos_1+1, pos_2-1) 24 | t <- get(eval(varname)) 25 | t1 <- substr(tex, 1, pos_1-1) 26 | t2 <- substr(tex, pos_2+1, end_pos) 27 | t1 <- paste0(t1, t, t2) 28 | cat(t1) 29 | } 30 | 31 | 32 | 33 | #cat with variables 34 | #cat_v(a) 35 | cat_v("This is text by: {vv} and today is a great day!") 36 | cat_v("This is text by: {vv}") 37 | 38 | 39 | -------------------------------------------------------------------------------- /functions/Dynamic_R.R: -------------------------------------------------------------------------------- 1 | # dynamic R 2 | 3 | 4 | dynamic <- "result <- 2 * 3" 5 | eval(parse(text = dynamic)) 6 | print(result) 7 | 8 | 9 | base_packages = getOption('defaultPackages') 10 | names(base_packages) = base_packages 11 | use 12 | bsp <- lapply(base_packages, function (pkg) ls(paste0('package:', pkg))) 13 | bs <- ls("package:base") 14 | 15 | #get random dataset 16 | sample(bsp$datasets,1) 17 | 18 | dynamic <- " 19 | base_packages <- getOption('defaultPackages'); 20 | bsp <- lapply(base_packages, function (pkg) ls(paste0('package:', pkg))); 21 | ds<-sample(bsp$datasets,1); 22 | " 23 | 24 | eval(parse(text = dynamic)) 25 | head(ds,10) 26 | 27 | 28 | # plotting 29 | dyn_plt = " 30 | xs <- seq(-2*pi,2*pi,pi/100) 31 | w <- sin(3*xs) 32 | plot(xs,w,type='l',ylim=c(-1,1)) 33 | abline(h=0,lty=3) 34 | " 35 | 36 | eval(parse(text = dyn_plt)) 37 | 38 | 39 | -------------------------------------------------------------------------------- /functions/EncryptText.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Encrypthing with password 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #21 7 | # Created: March 5, 2021 8 | # Author: Tomaz Kastrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | # 12 | # Changelog: 13 | ########################################### 14 | 15 | #install.packages("sodium") 16 | 17 | library(sodium) 18 | 19 | #Encrypt 20 | passkey <- sha256(charToRaw("geslo123")) 21 | plaintext <- "primer teksta" 22 | plaintext.serialized <- serialize(plaintext, NULL) 23 | 24 | #Decrypth 25 | ciphertext <- data_encrypt(plaintext.serialized, key = passkey) 26 | unserialize(data_decrypt(ciphertext, key = sha256(charToRaw("geslo123")))) 27 | 28 | 29 | ### Store passkey as variable 30 | unpkk <- "136 242 93 138 72 225 66 50 253 250 82 192 58 189 8 47 118 53 141 62 33 28 41 119 227 195 172 85 213 77 241 61" 31 | 32 | ciphertext <- data_encrypt(serialize(plaintext, NULL), key = unpkk) 33 | unserialize(data_decrypt(ciphertext, key = sha256(charToRaw("geslo123")))) 34 | 35 | s -------------------------------------------------------------------------------- /functions/Falling_snow.R: -------------------------------------------------------------------------------- 1 | ### not yet snow 2 | 3 | # ToDo: create animation with alternating / jitter flakes 4 | 5 | set.seed(2908) 6 | n <- 1000 7 | 8 | aa <- data.frame(x = runif(n), 9 | y = runif(n), 10 | size = runif(n, min = 4, max = 20), 11 | run = sample.int(100, 20)) 12 | 13 | #order aa 14 | aa <- aa[order(aa$x, aa$y),] 15 | 16 | 17 | ggplot(aa, aes(x, y, size = size)) + 18 | geom_point(color = "white", pch = 58, alpha=3/5) + # pch = 8 19 | scale_size_identity() + 20 | theme_void() + 21 | theme(panel.background = element_rect("black")) 22 | 23 | 24 | #animate -> lame :S 25 | library(gganimate) 26 | 27 | snow <- ggplot(aa, aes(x, y, size = size)) + 28 | geom_point(color = "white", pch = 58, alpha=3/5) + # pch = 8 29 | scale_size_identity() + 30 | theme_void() + 31 | theme(panel.background = element_rect("black")) 32 | 33 | 34 | # Running animation 35 | snow + 36 | transition_time(run) 37 | 38 | -------------------------------------------------------------------------------- /functions/FindingMaximumOfSubarrays.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Total Sum of sub-array 4 | # 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #37 8 | # Created: April 29, 2022 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | 13 | # Changelog: 14 | # 15 | ########################################### 16 | 17 | 18 | arr = c(1,2,3,4) 19 | 20 | sumArr <- function(x){ 21 | summ <- 0 22 | i <- 1 23 | for (i in 1:length(x)) { 24 | j <- i + 0 25 | midsum <- 0 26 | for (j in j:length(x)) { 27 | midsum <- sum(x[i:j]) 28 | summ <- summ + midsum 29 | #print(sum) 30 | } 31 | } 32 | cat(paste0("Total sum of sub-arrays: ", summ)) 33 | } 34 | 35 | sumArr(arr) 36 | 37 | 38 | 39 | sumArrOfMax <- function(x){ 40 | summ <- 0 41 | i <- 1 42 | for (i in 1:length(x)) { 43 | j <- i + 0 44 | midsum <- 0 45 | for (j in j:length(x)) { 46 | midsum <- max(x[i:j]) 47 | summ <- summ + midsum 48 | #print(sum) 49 | } 50 | } 51 | cat(paste0("Total sum of maximums of all sub-arrays: ", summ)) 52 | } 53 | 54 | 55 | sumArrOfMax(arr) 56 | 57 | 58 | set.seed(2908) 59 | #making bigger array 60 | arr2 <- as.numeric(sample(-100:100, 1000, replace=T)) 61 | 62 | # script stopped after 1 min 63 | sumArrOfMax(arr2) 64 | # 48690847 #running: 3 sec 65 | 66 | 67 | # Can we create a faster solution without changing the data types? 68 | 69 | -------------------------------------------------------------------------------- /functions/Flakes.R: -------------------------------------------------------------------------------- 1 | 2 | library(ggplot2) 3 | 4 | 5 | print_flakes <- function(nof){ 6 | df_snowflakes <- data.frame( 7 | x = runif(nof, 0, 20), 8 | y = runif(nof, 0, 20) ) 9 | 10 | shps <- c("+", "*", "o") 11 | random_shape <- sample(shps, size = 1) 12 | 13 | snowflake_plot <- ggplot(df_snowflakes, aes(x, y)) + 14 | geom_point(shape = random_shape, size = 2.6, color = "lightblue") + theme_void() 15 | 16 | print(snowflake_plot) 17 | } 18 | 19 | 20 | # run and print 1000 snowflakes 21 | print_flakes(1000) 22 | 23 | -------------------------------------------------------------------------------- /functions/FolderTreemap.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Generates useless Treemap of folders 4 | # and size for given directory 5 | # Series: 6 | # Little Useless-useful R functions #9 7 | # Created: December 30, 2020 8 | # Author: Tomaz Kastrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | # Changelog: 12 | # 13 | ########################################### 14 | 15 | #install.packages("treemap") 16 | library(treemap) 17 | 18 | 19 | FolderTreemap <- function(directory){ 20 | df <- NULL 21 | aa <- list.files(directory,full.names=TRUE) 22 | dirs <- aa[file.info(aa)$isdir] 23 | for (i in 1:length(dirs)){ 24 | name_f <- basename(dirs[i]) 25 | size_f <- sum(file.info(list.files(path=dirs[i], recursive = T, full.names = T))$size) 26 | df <- rbind(df, data.frame(size=size_f/(1024*1024), folder=name_f)) 27 | } 28 | p <- treemap(df, 29 | index=c("folder"), 30 | vSize="size", 31 | type="index", 32 | palette = "Set2", 33 | bg.labels=c("white"), 34 | title = paste0("Total size of folder: ",directory, " is: ", as.integer(sum(df$size)), " MiB.", collapse=NULL), 35 | align.labels=list(c("center", "center"), c("right", "bottom")) 36 | ) 37 | } 38 | 39 | input_directory <- "/users/tomazkastrun/Documents/Github" 40 | FolderTreemap(input_directory) 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | -------------------------------------------------------------------------------- /functions/FourInARow.R: -------------------------------------------------------------------------------- 1 | 2 | # load ggplot2 3 | ########################################## 4 | # 5 | # Making game 4-in-a-row 6 | # 7 | # Series: 8 | # Little Useless-useful R functions #55 9 | # Created: October 07, 2023 10 | # Author: Tomaz Kastrun 11 | # Blog: tomaztsql.wordpress.com 12 | # V.1.0 13 | 14 | # Changelog: 15 | ########################################### 16 | 17 | library(ggplot2) 18 | 19 | init_board <- function(r,c) { 20 | matrix(" ", nrow = r, ncol = c) 21 | } 22 | 23 | print_board <- function(board) { 24 | df <- data.frame(matrix) 25 | X <- "red" 26 | O <- "blue" 27 | ggplot(df, aes(x = nrow)) + geom_dotplot(col=X) + theme_void() 28 | } 29 | 30 | get_win <- function(board, player, row, col) { 31 | dirs <- list( 32 | c(0, 1),c(1, 0),c(1, 1),c(1, -1) 33 | ) 34 | dirsLabel <- c("down", "up", "left", "right") 35 | nof_tokens <- 42 #21 per players 36 | for (dir in dirs) { 37 | count <- 11 38 | for (i in 1:4) { 39 | r <- row + dir[1] * i 40 | c <- col + dir[2] * i 41 | if (r >= 1 && r <= nrow(board) && c >= 1 && c <= ncol(board) && board[r, c] == player) { 42 | count <- count + 1 43 | } else { 44 | break 45 | } 46 | } 47 | if (count >= 4) { 48 | return(TRUE) 49 | } 50 | } 51 | return(FALSE) 52 | } 53 | -------------------------------------------------------------------------------- /functions/Four_Fours.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Four Fours - Mathematical puzzle 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #16 7 | # Created: January 07, 2021 8 | # Author: Tomaz Kastrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | # Changelog: 12 | # 13 | ########################################### 14 | 15 | # Four Fours function 16 | four_fours <- function(maxnum) { 17 | for (i in 0:maxnum) { 18 | oper <- c("+","*", "-", "/") 19 | para <- c("(",")") 20 | step_counter <- 0 21 | res <- i + 1 22 | while (i != res) { 23 | oper3 <- sample(oper,4,replace=TRUE) 24 | for44 <- paste0("4",oper3[1],"4",oper3[2],"4",oper3[3],"4") 25 | 26 | #adding paranthesis 27 | # dif = 3, 5, 7 28 | stopit <- FALSE 29 | while (!stopit){ 30 | pos_par <<- sort(sample(1:7,2)) 31 | nn <- pos_par[1] 32 | mm <- pos_par[2] 33 | rr <<- abs(nn-mm) 34 | 35 | if (rr == 4 | rr == 5 ){ 36 | stopit <- TRUE 37 | 38 | } 39 | } 40 | 41 | for44 <- paste0(substr(for44, 1, nn-1), "(", substr(for44, nn, nchar(for44)), sep = "") 42 | for44 <- paste0(substr(for44, 1, mm-1+1), ")", substr(for44, mm+1, nchar(for44)), sep = "") 43 | 44 | # if (for44 ) like "(/" or "(-" or "(*" or "(+" -> switch to -> "/(" or "-(" 45 | for44 <- gsub("\\(-", "-\\(", for44) 46 | for44 <- gsub("\\(/", "/\\(", for44) 47 | for44 <- gsub("(*", "*(", for44, fixed=TRUE) 48 | for44 <- gsub("(+", "+(", for44, fixed=TRUE) 49 | for44 <- gsub("\\+)", "\\)+", for44) 50 | for44 <- gsub("\\-)", "\\)-", for44) 51 | for44 <- gsub("\\*)", "\\)*", for44) 52 | for44 <- gsub("\\/)", "\\)/", for44) 53 | 54 | 55 | ### Adding SQRT 56 | if (i >= 10){ 57 | lii <- lapply(strsplit(as.character(for44), ""), function(x) which(x == "4")) 58 | start_pos <- sample(lii[[1]],1) 59 | for44 <- paste0(substr(for44, 1, start_pos-1), "sqrt(", substr(for44, start_pos, start_pos), ")", substr(for44, start_pos+1, nchar(for44)),sep = "") 60 | } 61 | 62 | ### Adding Factorial 63 | if (i >= 11){ 64 | li <- lapply(strsplit(as.character(for44), ""), function(x) which(x == "4")) 65 | start_pos_2 <- sample(li[[1]],1) 66 | for44 <- paste0(substr(for44, 1, start_pos_2-1), "factorial(", substr(for44, start_pos_2, start_pos_2), ")", substr(for44, start_pos_2+1, nchar(for44)),sep = "") 67 | } 68 | 69 | res <- eval(parse(text=for44)) 70 | #print(paste0("vrednost: ",i,". formula: ", for44, ". rezultat: ",res ,collapse=NULL)) 71 | step_counter <- step_counter + 1 72 | if (res==i){ 73 | print(paste0("Value: ", res, " was found formula: ", for44, " with result: ", res, " and steps: ", step_counter, collapse=NULL)) 74 | } 75 | 76 | } 77 | i <- i + 1 78 | } 79 | 80 | } 81 | 82 | #Run function 83 | four_fours(15) 84 | -------------------------------------------------------------------------------- /functions/Friday13.R: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/functions/Friday13.R -------------------------------------------------------------------------------- /functions/FunctionNames.R: -------------------------------------------------------------------------------- 1 | # combine 2 | 3 | a <- c(0,0,0,0.2) 4 | 5 | c <- function(a,b){ 6 | return("aaaa") 7 | } 8 | 9 | a <- c("a","b") 10 | #error 11 | a <- c(0,0,0,0.2) 12 | 13 | # True / False 14 | 15 | False <- FALSE 16 | True <- TRUE 17 | 18 | isTRUE(True) 19 | identical(True, TRUE) 20 | 21 | 22 | # sum function 23 | sum <- function(x){ 24 | mean(x) 25 | } 26 | sum(c(10,20,40,20)) 27 | 28 | 29 | 30 | #Letters 31 | 32 | LETTERS 33 | letters 34 | 35 | #numbers 36 | 37 | numbers <- c(0,1,2,3,4,5,6,7,8,9) 38 | 39 | NUMBERS <- c("0","1","2","3","4","5","6","7","8","9") 40 | 41 | numbers 42 | NUMBERS 43 | 44 | 45 | 46 | ca <- function(x, y, op) { 47 | switch(op, 48 | plus = x + y, 49 | minus = x - y, 50 | times = x * y, 51 | divide = x / y, 52 | stop("Unknown op!") 53 | ) 54 | } 55 | 56 | 57 | mean_ci <- function(x, conf = 0.95) { 58 | se <- sd(x) / sqrt(length(x)) 59 | alpha <- 1 - conf 60 | mean(x) + se * qnorm(c(alpha / 2, 1 - alpha / 2)) 61 | } 62 | 63 | mean_ci(10:15) 64 | sd(c(10,22,23,45)) 65 | 66 | 67 | -------------------------------------------------------------------------------- /functions/FunctionTwist.R: -------------------------------------------------------------------------------- 1 | ################################### 2 | # 3 | # function to call a function 4 | # Function twist 5 | # Circular or recursive functions 6 | # 7 | ################################### 8 | 9 | fun1 <- function(x, num){ 10 | 11 | #res <- x(num) 12 | res <- do.call(x, num) 13 | return(res) 14 | } 15 | 16 | 17 | fun2 <- function(num){ 18 | 19 | return(num*num) 20 | } 21 | 22 | fun2(4) 23 | fun1(fun2, 4) 24 | fun1(fun2,list(4)) 25 | 26 | 27 | 28 | ######## circle functions without exit 29 | 30 | fn1 <- function(n){ 31 | return(n*n*fn2(n)) 32 | } 33 | 34 | 35 | fn2 <- function(m){ 36 | return((m+m)) #+fn2(m-1)) ## We need to give it a limit; without refencing self or reducing steps m-1 37 | 38 | } 39 | 40 | fn1(3) 41 | fn2(3) 42 | 43 | 44 | #### example with recursion 45 | 46 | sum_ser <- function(n) 47 | { 48 | if(n == 0) { 49 | #return ((n * n+1) + sum_ser(n - 1)) 50 | return (0) 51 | } else { 52 | return ((n * n) + sum_ser(n - 1)) 53 | } 54 | } 55 | 56 | sum_ser(4) 57 | 58 | 59 | 60 | #### Info about stack 61 | Cstack_info() 62 | 63 | 64 | ##### similar circular function 65 | ## Changing from list to vector hitting stack limit (classical case) 66 | 67 | to_vector <- function(x){ 68 | x <- to_list(x) 69 | as.list(x) 70 | } 71 | 72 | to_list <- function(x){ 73 | x <- to_vector(x) 74 | as.vector(x) 75 | } 76 | 77 | to_vector(2908) 78 | 79 | 80 | 81 | ### Another function; calling itself 82 | 83 | rn <- function(a=2){ 84 | res <- sample(a) 85 | rn(res) 86 | } 87 | 88 | rn(10) 89 | 90 | 91 | 92 | ### Recursions in Mathematics (Factorial / Fibonnaci ) 93 | 94 | fact <- function(x){ 95 | if(x == 0){ 96 | return(0) 97 | } 98 | if(x==1){ 99 | return(1) 100 | } else { 101 | return(x*fact(x-1)) 102 | } 103 | } 104 | 105 | fact(4) 106 | 107 | fact(-4) 108 | 109 | ## Fibonacci sequence 110 | recurse_fibonacci_sum <- function(n) { 111 | if(n <= 1) { 112 | return(n) 113 | } else { 114 | return(recurse_fibonacci_sum(n-1) + recurse_fibonacci_sum(n-2)) 115 | } 116 | } 117 | 118 | print_fibonacci <- function(x){ 119 | vc <- c() 120 | for(i in 0:(x-1)) { 121 | vc <- c(vc, recurse_fibonacci_sum(i)) 122 | } 123 | cat(vc) 124 | } 125 | 126 | 127 | 128 | print_fibonacci(15) 129 | 130 | ################################# 131 | ### Simple sorting with recursion 132 | ################################# 133 | 134 | quacksort <- function(setN){ 135 | if(length(setN)<=1 | length(setN)==0) { 136 | return(setN) 137 | } else { 138 | home <- setN[1] 139 | rest <- setN[-1] 140 | rest_set <- rest[rest > home] 141 | home_set <- rest[rest <= home] 142 | rest_set <- quacksort(rest_set) 143 | home_set <- quacksort(home_set) 144 | return((c(home_set,home,rest_set))) 145 | } 146 | } 147 | 148 | series <- c(65,963,12,-256,529,57,12,778, 0, 54,333,-12345,12, 1,43423,5,7786,43,23,5,67,9098,5,33,22) 149 | 150 | #series 151 | quacksort(series) 152 | 153 | #single number 154 | quacksort(4) 155 | 156 | -------------------------------------------------------------------------------- /functions/GARCH.R: -------------------------------------------------------------------------------- 1 | #GARCH Time Series error estimation serially calculation 2 | 3 | library(fGarch) 4 | library(tseries) 5 | library(fBasics) 6 | 7 | 8 | google.fit <- garchFit(formula = ~ arma(1, 1) + garch(1, 1), 9 | data = google.d, 10 | include.mean=TRUE) 11 | 12 | 13 | google<-data.frame(google) 14 | google<-ts(google) 15 | google.d<-diff(log(google)) 16 | 17 | 18 | 19 | epsilon <- rnorm(200, 0, 1) 20 | alpha_0 = 2 21 | alpha_1 = 2 22 | y = c(1) 23 | sigma = c() 24 | for (i in 1:length(epsilon)){ 25 | #Tính sigma_t 26 | sigma_t = sqrt(alpha_0 + alpha_1*y[length(y)]^2) 27 | sigma = c(sigma, sigma_t) 28 | #Tính y_t 29 | y_t = sigma_t*epsilon[i] 30 | y = c(y, y_t) 31 | } 32 | 33 | y <- y[2:length(y)] 34 | plot(y, type = 'l') 35 | 36 | 37 | 38 | ## 200,1 39 | epsilon <- rnorm(200, 0, 1) 40 | alpha_0 = 2 41 | alpha_1 = 0.5 42 | y = c(1) 43 | sigma = c() 44 | for (i in 1:length(epsilon)){ 45 | #Tính sigma_t 46 | sigma_t = sqrt(alpha_0 + alpha_1*y[length(y)]^2) 47 | sigma = c(sigma, sigma_t) 48 | #Tính y_t 49 | y_t = sigma_t*epsilon[i] 50 | y = c(y, y_t) 51 | } 52 | 53 | y <- y[2:length(y)] 54 | y[1:10] -------------------------------------------------------------------------------- /functions/GenerateCalculator.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Script that generates script for basic 4 | # calculator functions for integers 5 | # between 1 and 10 6 | # Series: 7 | # Little Useless-useful R functions #9 8 | # Created: November 28, 2020 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | 13 | # Changelog: 14 | # - adding x11() 15 | ########################################### 16 | 17 | # Basic concept 18 | calc <- function(a,b,oper){ 19 | if(a==1 & b==1 & oper=="+"){print("Result is 2")} 20 | if(a==1 & b==1 & oper=="-"){print("Result is 0")} 21 | if(a==1 & b==1 & oper=="*"){print("Result is 1")} 22 | if(a==1 & b==1 & oper=="/"){print("Result is 1")} 23 | } 24 | 25 | calc(1,1,"-") 26 | calc(1,1,"+") 27 | calc(1,1,"*") 28 | calc(1,1,"/") 29 | 30 | ###################### 31 | ## 32 | ## creating function 33 | ## to generate script 34 | ## 35 | ###################### 36 | 37 | # set all combinations 38 | df <- data.frame(merge(merge(c(1:10), c(1:10), by=NULL), c("+","-","/","*"), by=NULL)) 39 | colnames(df) <- c("numberA", "numberB", "oper") 40 | f <- "calc <- function(a,b,oper){" 41 | for (i in 1:nrow(df)){ 42 | res <- paste0(as.character(df$numberA[i]) , df$oper[i], as.character(df$numberB[i])) 43 | rr <- eval(parse(text=res)) 44 | f1 <- paste0(' if(a==',as.character(df$numberA[i]), ' & b==', as.character(df$numberB[i]), ' & oper==', '"',as.character(df$oper[i]),'"' , 45 | '){print("Result is ', as.character(rr),'")}', '\n' , collapse=NULL) 46 | f <<- paste0(f, f1, collapse = NULL) 47 | if(i==nrow(df)){ 48 | f <<- paste0(f, "}", collapse = NULL) 49 | eval(parse(text=f)) 50 | } 51 | } 52 | 53 | calc(4,5,"/") 54 | 55 | 56 | 57 | ###################### 58 | ## 59 | ## Alternative solution 60 | ## (by mrdwab https://github.com/mrdwab) 61 | ## using expand.grid 62 | ## sprintf 63 | ## sapply 64 | ## 65 | ###################### 66 | 67 | df <- expand.grid(numA = 1:10, oper = c("+", "-", "/", "*"), numB = 1:10, stringsAsFactors = FALSE) 68 | rr <- sapply(1:nrow(df), function(x) match.fun(df[x, "oper"])(df[x, "numA"], df[x, "numB"])) 69 | template <- ' if (a == %s & b == %s & oper == "%s") print("Result is %g")\n ' 70 | f <- sprintf("calc <- function(a, b, oper) {\n%s\n}", 71 | paste0(with(df, sprintf(template, numA, numB, oper, rr)), collapse = "")) 72 | eval(parse(text = f)) 73 | 74 | 75 | -------------------------------------------------------------------------------- /functions/GenerateQRCode.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # DGenerating QR code 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #20 7 | # Created: March 5, 2021 8 | # Author: Tomaz Kastrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | 12 | # Changelog: 13 | # - adding new functions 14 | ########################################### 15 | 16 | 17 | library(qrcode) 18 | 19 | #Saves to file 20 | png("code.png") 21 | qrcode_gen("https://tomaztsql.wordpress.com/") 22 | dev.off() 23 | 24 | 25 | #Plots in Studio 26 | qrcode_gen("https://tomaztsql.wordpress.com/") 27 | -------------------------------------------------------------------------------- /functions/Generate_data_with_correlations.R: -------------------------------------------------------------------------------- 1 | library(ggplot2) 2 | library(dplyr) 3 | library(tidyr) 4 | library(faux) 5 | 6 | 7 | dat <- rnorm_multi(n = 100, 8 | mu = c(0, 20, 20), 9 | sd = c(1, 5, 5), 10 | r = c(0.5, 0.5, 0.25), 11 | varnames = c("A", "B", "C"), 12 | empirical = FALSE) 13 | 14 | 15 | 16 | bvn <- rnorm_multi(100, 5, 0, 1, .3, varnames = letters[1:5]) 17 | 18 | 19 | cmat <- cor(iris[,1:4]) 20 | bvn <- rnorm_multi(100, 4, 0, 1, cmat, 21 | varnames = colnames(cmat)) 22 | 23 | 24 | cmat <- c(1, .3, .5, 25 | .3, 1, 0, 26 | .5, 0, 1) 27 | bvn <- rnorm_multi(100, 3, 0, 1, cmat, 28 | varnames = c("first", "second", "third")) 29 | 30 | 31 | rho1_2 <- .3 32 | rho1_3 <- .5 33 | rho1_4 <- .5 34 | rho2_3 <- .2 35 | rho2_4 <- 0 36 | rho3_4 <- -.3 37 | cmat <- c(rho1_2, rho1_3, rho1_4, rho2_3, rho2_4, rho3_4) 38 | bvn <- rnorm_multi(100, 4, 0, 1, cmat, 39 | varnames = letters[1:4]) 40 | 41 | 42 | 43 | # empirical true 44 | 45 | bvn <- rnorm_multi(100, 5, 0, 1, .3, 46 | varnames = letters[1:5], 47 | empirical = T) 48 | 49 | 50 | dat <- rnorm_multi(varnames = "A") %>% 51 | mutate(B = rnorm_pre(A, mu = 10, sd = 2, r = 0.5)) 52 | 53 | 54 | dat$C <- rnorm_pre(dat$A, mu = 10, sd = 2, r = 0.5, empirical = TRUE) 55 | 56 | dat$D <- rnorm_pre(dat, r = c(.1, .2, .3), empirical = TRUE) 57 | 58 | summary(dat) 59 | cor(dat) 60 | 61 | 62 | 63 | 64 | 65 | 66 | #### 67 | # generate X, Y Variables of sample size 200 with r coeff of 0.91 68 | samples = 200 69 | r_coef = 0.91 70 | 71 | data <- rnorm_multi(n = samples, vars = 3, r=(0.91), varnames = c("X", "Y", "Z"), empirical = TRUE) 72 | 73 | head(data) 74 | cor(data) 75 | 76 | 77 | 78 | cor_mat <- cormat(r, vars) 79 | sigma <- (sd %*% t(sd)) * cor_mat 80 | 81 | p <- length(mu) 82 | if (!all(dim(sigma) == c(p, p))) stop(err) 83 | eS <- eigen(sigma, symmetric = TRUE) 84 | ev <- eS$values 85 | if (!all(ev >= -1e-06 * abs(ev[1L]))) stop(paste(err)) 86 | X <- matrix(stats::rnorm(p * n), n) 87 | if (empirical) { 88 | X <- scale(X, TRUE, FALSE) 89 | X <- X %*% svd(X, nu = 0)$v 90 | X <- scale(X, FALSE, TRUE) 91 | } 92 | 93 | 94 | library(MASS) 95 | #MASS::mvrnorm 96 | -------------------------------------------------------------------------------- /functions/GeneratingCookingRecipes.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Generating cooking recipes 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #24 7 | # Created: June 20, 2021 8 | # Author: Tomaž Kaštrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | # 12 | # Changelog: 13 | ########################################### 14 | 15 | ingredients <- c("Pasta","Rice","All-purpose flour","sugar","Baking powder","Butter","Eggs","Lemons", "Salt") 16 | quantites <- c("Piece(s)", "Gram(s)", "Liter(s)", "Bowl") 17 | actions <- c("Slice","Bake","Refrigerate","Cook","Steam","Dip","Leave to Rest", "grill") 18 | Kitchen_supply <- c("spatula", "oven", "refrigerator", "pan", "sauce-pan", "whisk") 19 | steps <- c("1-1", "1-2-1", "1-2-2", "2", "1") 20 | steps_des <- c("Take ", "and", "make", "bake") 21 | 22 | 23 | string_1 <- as.vector(sample(ingredients,1,replace=F)) 24 | string_2 <- as.vector(sample(actions,1,replace=F)) 25 | 26 | recipe <- paste(string_1,string_2,sep = " ") 27 | 28 | 29 | 30 | #combn(ingredients,2) 31 | 32 | Rec_Ing <- c(Rec_Ing, sample(c(quantites))) 33 | 34 | 35 | 36 | RandomRecipe <- function(actions=0, ingredients=0, quantites=0, Steps=0, Kitchen_supply=0) { 37 | Rec_Ing <- " " 38 | if(quantites>0) Rec_Ing <- c(Rec_Ing, sample(c(quantites))) 39 | if(ingredients>0) Rec_Ing <- c(Rec_Ing, sample(ingredients)) 40 | if(actions>0) Rec_Ing <- c(Rec_Ing, sample(actions)) 41 | if(Steps>0) Rec_Ing <- c(Rec_Ing, sample(Steps)) 42 | if(Kitchen_supply>0) Rec_Ing <- c(Rec_Ing, sample(Kitchen_supply)) 43 | 44 | cat(sample(Rec_Ing, length(Rec_Ing))) 45 | } 46 | 47 | RandomRecipe(ingredients =10, quantites=2, Steps=4) 48 | 49 | 50 | 51 | 52 | -------------------------------------------------------------------------------- /functions/Generating_image.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Random image 4 | # 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #44 8 | # Created: November 25, 2022 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | # 13 | # Changelog: 14 | # 15 | ########################################## 16 | 17 | 18 | ### Function 1 - using trigon. angle func. 19 | 20 | # angle = sin, cos, tan 21 | random_image <- function(num, pow, val,len, angle) { 22 | available_angle <- c('sin', 'cos', 'tan') 23 | stopifnot(angle %in% available_angle) { 24 | 25 | x <- y <- seq((-num)*pi, (num)*pi, length.out = len) 26 | r <- sqrt(outer(x^2, y^2, "^")) 27 | image(z = z <- {{angle}}(r^pow)*exp(-r/(val)), col = gray.colors(36)) 28 | image(z, axes = FALSE) 29 | contour(z, add = TRUE, drawlabels = TRUE) 30 | } 31 | } 32 | 33 | # runfun 34 | random_image(0.5,0.1,20,150, cos) 35 | random_image(0.5,10,20,150, sin) 36 | 37 | 38 | ### 2. Simplified versions 39 | 40 | image(matrix(runif(50*50), ncol=50)) 41 | image(outer(1:10, 1:12, "log")) 42 | image(outer(1:10, 1:12, "*"), useRaster = TRUE) 43 | 44 | 45 | ### 3. Plotting useless statistics 46 | 47 | iris <- iris 48 | image(outer(iris$Sepal.Length, iris$Petal.Length)) 49 | image(outer(iris$Sepal.Length, iris$Sepal.Width)) 50 | 51 | -------------------------------------------------------------------------------- /functions/Github_HeatMap.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # ggplot Heatmap that looks like Github 4 | # contribution chart 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #42 8 | # Created: August 27, 2022 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | # 13 | # Changelog: 14 | # 15 | ########################################### 16 | 17 | 18 | # Library 19 | library(ggplot2) 20 | 21 | colours <- c("#ebedf0", "#9be9a8", "#40c463","#309b4c","#216e39") 22 | # colours: lavender, palegreen, mediumseagreen,seagreen, forestgreen 23 | # nof_contributions: 0, 1, 2-5, 5-10, 10+ 24 | 25 | 26 | # Generate grid 27 | y <- weekdays(Sys.Date()+0:6) # days 28 | x <- paste0("W_", seq(1,52)) 29 | data <- expand.grid(X=x, Y=y) 30 | data$cols <- sample(colours, 364, replace=TRUE) 31 | 32 | 33 | # Contribution graph 34 | ggplot(data, aes(X, Y)) + 35 | geom_tile(aes(fill = cols, width=0.9, height=0.9)) + 36 | scale_fill_manual(values=colours) + 37 | labs(title = "Your R generated contributions in past year") + 38 | theme(axis.title.x = element_blank(), 39 | axis.title.y = element_blank(), 40 | axis.ticks.x=element_blank(), 41 | axis.ticks.y=element_blank(), 42 | legend.position = "none", 43 | panel.background = element_rect(fill = 'white', color = 'white') 44 | ) 45 | 46 | 47 | 48 | ################## 49 | # square graph 50 | # remember your local pool :-) 51 | ################## 52 | 53 | # Generate grid 54 | colours <- c("#ebedf0", "#9be9a8", "#40c463","#309b4c","#216e39") 55 | y <- LETTERS[1:60] # letters 56 | x <- seq(1,60) 57 | data <- expand.grid(X=x, Y=y) 58 | data$cols <- sample(colours, 3600, replace=TRUE) 59 | 60 | ggplot(data, aes(X, Y)) + 61 | geom_tile(aes(fill = cols, width=0.95, height=0.95)) + 62 | scale_fill_manual(values=colours) + 63 | labs(title = "Your local pool tiles") + 64 | theme(axis.title.x = element_blank(), 65 | axis.title.y = element_blank(), 66 | axis.ticks.x=element_blank(), 67 | axis.ticks.y=element_blank(), 68 | axis.text.x=element_blank(), 69 | axis.text.y=element_blank(), 70 | legend.position = "none", 71 | panel.background = element_rect(fill = 'white', color = 'white') 72 | ) 73 | -------------------------------------------------------------------------------- /functions/Goldbach_conjecture.R: -------------------------------------------------------------------------------- 1 | 2 | ########################################## 3 | # 4 | # 5 | # Goldbach's Conjecture 6 | # Two primes for a given sum (even int) 7 | # 8 | # Series: 9 | # Little Useless-useful R functions #52 10 | # Created: Jul 15, 2023 11 | # Author: Tomaz Kastrun 12 | # Blog: tomaztsql.wordpress.com 13 | # V.1.0 14 | # 15 | # Changelog: 16 | # 17 | ########################################## 18 | 19 | # sieve of sundaram 20 | sieve_of_sundaram <- function(limit) { 21 | n <- (limit - 1) %/% 2 22 | sieve <- rep(TRUE, n + 1) 23 | 24 | for (i in 1:n) { 25 | j <- 1 26 | while (i+j+2*i*j <= n) { 27 | sieve[i+j+2*i*j] <- FALSE 28 | j <- j + 1 29 | } 30 | } 31 | primes <- c(2,(2*(1:n)+1)[sieve]) 32 | return(primes) 33 | } 34 | 35 | 36 | #list of all primes until "limit" 37 | #sieve_of_sundaram(limit) 38 | 39 | 40 | 41 | # is prime 42 | is_prime <- function(n) { 43 | if (n <= 1) return(FALSE) 44 | if (n <= 3) return(TRUE) 45 | if (n %% 2 == 0 || n %% 3 == 0) return(FALSE) 46 | i <- 5 47 | while (i*i <= n) { 48 | if (n %% i == 0 || n %% (i + 2) == 0) return(FALSE) 49 | i <- i + 6 50 | } 51 | return(TRUE) 52 | } 53 | 54 | 55 | ## goldbach for even numbers 56 | goldbach_conjecture <- function(even_num) { 57 | if (even_num <= 2 || even_num %% 2 != 0) { 58 | return("Number must be even and greater than 2.") 59 | } 60 | c <- NULL 61 | for (i in 2:(even_num / 2)) { 62 | if (is_prime(i) && is_prime(even_num - i)) { 63 | #cat("Goldbach's pairs for", even_num, "are:", i, "+", even_num - i, "\n") 64 | c <- cbind(c,i) # nof solutions 65 | } 66 | } 67 | #return(length(c)) 68 | return(c) 69 | } 70 | 71 | # test 72 | goldbach_conjecture(870) 73 | 74 | 75 | #make some 1000 solutions 76 | sol <- NULL 77 | for (i in seq(4,1000, by=2)){ 78 | nof_solutions <- goldbach_conjecture(i) 79 | sol <- rbind(sol, data.frame(n=i, nof=nof_solutions)) 80 | } 81 | 82 | 83 | # plot solutions; alternating solutions 84 | plot(sol$n, sol$nof, type = "p", xlab = "Even number", ylab = "Number of Solutions", main = "Goldbach's Conjecture") 85 | reg<-lm(nof ~ n, data = sol) 86 | abline(reg, col="red") 87 | 88 | 89 | # most frequent primes: 90 | fre <- NULL 91 | for (i in seq(4,1000, by=2)){ 92 | sols <- goldbach_conjecture(i) 93 | fre <- cbind(fre, sols) 94 | } 95 | 96 | # prepare solutions 97 | solutions_freq<- data.frame(table(t(fre))) 98 | 99 | # visualisation 100 | solutions_freq <- solutions_freq[which(as.integer(solutions_freq$Freq) > 1),] 101 | plot(x=solutions_freq$Var1, y=solutions_freq$Freq, 102 | xlab = "Prime number", ylab = "Frequency of prime in sum", main = "Frequencies of prime numbers for 103 | Goldbach's Conjecture for first \n 1000 even integers.") 104 | 105 | -------------------------------------------------------------------------------- /functions/HelloRversion.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Script for outputing R version 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #17 7 | # Created: February 02, 2021 8 | # Author: Tomaz Kastrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | 12 | # Changelog: 13 | # 14 | ########################################### 15 | 16 | library(dplyr) 17 | 18 | HelloRversion <- function(text=TRUE){ 19 | 20 | if (text==TRUE){ 21 | # Get some text 22 | text_R <- "580a000000030003060300030500000000055554462d38000000100000000100040009000001284820202048204545454545204c20202020204c2020202020204f4f4f2020202020202052525252202020202121200a4820202048204520202020204c20202020204c20202020204f2020204f20202020202052202020522020202121200a4848484848204545454545204c20202020204c20202020204f2020204f20202020202052525252202020202121200a4820202048204520202020204c20202020204c20202020204f2020204f202020202020522020205220202020200a4820202048204545454545204c4c4c4c4c204c4c4c4c4c20204f4f4f20202020202020522020205220202021210a2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d2d0a202020202020202020207c207665723a20" 23 | } else { 24 | text_R <- "580a000000030003060300030500000000055554462d380000001000000001000400090000021d202020202020202020202020202020202020202020202020202020202020202020205f5f0a202020202020202020202020202020202020202020202020202020202020205f2e2d7e2020290a20202020202020202020202020202020202020205f2e2e2d2d7e7e7e7e2c272020202c2d2f20202020205f0a20202020202020202020202020202020202e2d272e202e202e202e272020202c2d272c27202020202c2720290a2020202020202020202020202020202c272e202e202e205f2020202c2d2d7e2c2d275f5f2e2e2d2720202c270a202020202020202020202020202c272e202e202e202028402927202d2d2d7e7e7e7e2020202020202c270a2020202020202020202020202f2e202e202e202e20277e7e202020202020202020202020202c2d270a20202020202020202020202f2e202e202e202e202e202020202020202020202020202c2d270a202020202020202020203b202e202e202e202e20202d202e20202020202020202c270a2020202020202020203a202e202e202e202e202020202020205f20202020202f0a20202020202020202e202e202e202e202e20202020202020202020602d2e3a0a202020202020202e202e202e202e2f20202d202e20202020202020202020290a2020202020202e20202e202e207c20205f5f5f5f5f2e2e2d2d2d2e2e5f2f200a7e2d2d2d7e7e7e7e2d2d2d2d7e7e7e7e202020202020202020202020207e7e0a2020202020207c207665723a20" 25 | } 26 | 27 | # Get R version 28 | vR<- trimws(gsub("\\(.*?\\)", "", sub("R version ","",R.version$version.string))) 29 | 30 | 31 | unserialized_vR <- text_R %>% 32 | {substring(., seq(1, nchar(.), 2), seq(2, nchar(.), 2))} %>% 33 | paste0("0x", .) %>% 34 | as.integer %>% 35 | as.raw %>% 36 | unserialize() 37 | 38 | unserialized_vR <- paste0(unserialized_vR,vR,' |') 39 | 40 | 41 | cat("\014") # or cat("\f") if running on Windows 42 | cat(unserialized_vR) 43 | } 44 | 45 | # Run function 46 | HelloRversion() 47 | HelloRversion(FALSE) 48 | -------------------------------------------------------------------------------- /functions/HelloRversion_HelperFile.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # SHelper file for HelloRVersion 4 | # Script for outputing R version 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #17 8 | # Created: February 02, 2021 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | 13 | # Changelog: 14 | # 15 | ########################################### 16 | 17 | 18 | ### TRUE 19 | 20 | r1 <- paste("H H EEEEE L L OOO RRRR !! 21 | H H E L L O O R R !! 22 | HHHHH EEEEE L L O O RRRR !! 23 | H H E L L O O R R 24 | H H EEEEE LLLLL LLLLL OOO R R !! 25 | --------------------------------------------- 26 | | ver: ") 27 | 28 | serialized_r1 <- r1 %>% 29 | serialize(NULL) %>% 30 | as.character() %>% 31 | paste0(collapse = "") 32 | 33 | serialized_r1 34 | 35 | 36 | ### FALSE 37 | r2 <- paste(" __ 38 | _.-~ ) 39 | _..--~~~~,' ,-/ _ 40 | .-'. . . .' ,-',' ,' ) 41 | ,'. . . _ ,--~,-'__..-' ,' 42 | ,'. . . (@)' ---~~~~ ,' 43 | /. . . . '~~ ,-' 44 | /. . . . . ,-' 45 | ; . . . . - . ,' 46 | : . . . . _ / 47 | . . . . . `-.: 48 | . . . ./ - . ) 49 | . . . | _____..---.._/ 50 | ~---~~~~----~~~~ ~~ 51 | | ver: ") 52 | 53 | serialized_r2 <- r2 %>% 54 | serialize(NULL) %>% 55 | as.character() %>% 56 | paste0(collapse = "") 57 | 58 | serialized_r2 59 | -------------------------------------------------------------------------------- /functions/InteractiveVoronoiGraphGenerator.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Interactive Voronoi graph generator 4 | # with R 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #30 8 | # Created: November 01, 2021 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | 13 | # Changelog: 14 | # - adding distance with ggvoronoi 15 | ########################################### 16 | 17 | 18 | # packages 19 | library(deldir) 20 | library(ggplot2) 21 | #library(ggvoronoi) 22 | 23 | dff <- data.frame(NULL,NULL,NULL) 24 | 25 | #### Graph 26 | voronoiGraphBoard <- function(){ 27 | r <- ggplot(data=dff, aes(x=xl,y=yl)) + 28 | geom_segment( aes(x = x1, y = y1, xend = x2, yend = y2), size = 1, data = voronoi$dirsgs, linetype = 1, color= "orange") + 29 | geom_point( shape=21, size = 3, color="red", fill="blue") + 30 | #geom_voronoi(aes(x=xl,y=yl,fill=distance)) + 31 | theme_void() 32 | 33 | return(r) 34 | } 35 | 36 | ### Clicking on canvas 37 | click <- function(DefaultGraph=voronoiGraphBoard(), steps=st){ 38 | DefaultGraph <- plot.new() 39 | for (n in 1:steps) { 40 | mouse.at <- locator(n = 1, type = "o") 41 | xl <- mouse.at$x 42 | yl <- mouse.at$y 43 | distance <- sqrt((xl-100)^2 + (yl-100)^2) 44 | df <- data.frame(xl,yl, distance) 45 | dff <<- rbind(dff, df) 46 | if (nrow(dff)>=2){ 47 | voronoi <<- deldir(dff$xl, dff$yl) 48 | DefaultGraph <- voronoiGraphBoard() 49 | print(DefaultGraph) 50 | } 51 | } 52 | } 53 | 54 | 55 | #### Start with x11 56 | Draw_x11 <- function(st){ 57 | x11() 58 | click(steps=st) 59 | DefaultGraph <<- voronoiGraphBoard() 60 | } 61 | 62 | # Generate Voronoi with defined steps 63 | Draw_x11(st=20) 64 | 65 | 66 | -------------------------------------------------------------------------------- /functions/IsDatasetSame.R: -------------------------------------------------------------------------------- 1 | 2 | ########################################## 3 | # 4 | # Are two dataframes same? 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #24 8 | # Created: May 27, 2021 9 | # Author: Tomaž Kaštrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | 13 | # Changelog: 14 | ########################################### 15 | library("compareDF") 16 | #install.packages("compareDF") 17 | 18 | # two samples of Dataframe 19 | ds1 <- data.frame(col1=c("t1","t2","t3","s4"),col2=c(1,2,5,7)) 20 | ds2 <- data.frame(col1=c("t1","t2","t3","s4"),col2=c(1,2,5,8)) 21 | 22 | 23 | #using equality with all.equal 24 | all.equal(ds1,ds2,check.attributes = TRUE, use.names = TRUE) 25 | 26 | 27 | # Using compareDF difference / equality 28 | 29 | df_compare <- compare_df(ds1, ds2, "col2") 30 | df_compare$comparison_df 31 | 32 | -------------------------------------------------------------------------------- /functions/IsItFullMoon.R: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/functions/IsItFullMoon.R -------------------------------------------------------------------------------- /functions/IsItRaining.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Is it raining? 4 | # With help of openweathermapAPI 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #25 8 | # Created: June 20, 2021 9 | # Author: Tomaž Kaštrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | # 13 | # Changelog: 14 | ########################################### 15 | 16 | library(jsonlite) 17 | 18 | 19 | isItRainingYet <- function(city){ 20 | 21 | #get api 22 | #Ljubljana, Slovenija 23 | API_key = "5xxxxeexxxxxcbyyyy8xxxxxexxxxxxa1" 24 | City_name = city #"Ljubljana" 25 | 26 | api <- paste0("http://api.openweathermap.org/data/2.5/weather?q=",City_name,"&appid=",API_key) 27 | res <- fromJSON(api) 28 | perc <- res$clouds$all[1] 29 | perc <- as.integer(perc) 30 | 31 | rain <- " " 32 | if (perc<=20) rain <-'Meeh' 33 | if (perc>20 & perc<=60) rain <- 'Huuuh, but still meeh' 34 | if (perc>60 & perc<=85) rain <- 'Looking better' 35 | if (perc>85) rain <- 'Bring it on!' 36 | 37 | 38 | return(rain) 39 | 40 | } 41 | 42 | 43 | isItRainingYet("Ljubljana") 44 | 45 | -------------------------------------------------------------------------------- /functions/KadaneAlgorithm.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Kadane's algorithm 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #36 7 | # Created: March 28, 2022 8 | # Author: Tomaz Kastrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | 12 | # Changelog: 13 | # 14 | ########################################### 15 | 16 | 17 | ## Home edition 18 | v <- c(-3,-8, 1, -2, 1, 5, -3, -4, 3, 10, -2, 4, 1) 19 | 20 | 21 | kadane <- function(v){ 22 | 23 | max_so_far = -999999999999999 #some obnoxiously big number 24 | max_ending_here = 0 25 | start = 0 26 | end = 0 27 | s = 0 28 | 29 | for (i in 1:length(v)) { 30 | max_ending_here = max_ending_here + v[i] 31 | if (max_so_far < max_ending_here ){ 32 | max_so_far = max_ending_here 33 | start = s 34 | end = i 35 | } 36 | if (max_ending_here < 0) { 37 | max_ending_here = 0 38 | s = i+1 39 | } 40 | } 41 | #return (max_so_far) 42 | cat("Sum is: ", max_so_far, " with starting position: ", start, " and ending: ", end) 43 | } 44 | 45 | 46 | kadane(v) 47 | 48 | 49 | 50 | ######################### 51 | #using adagio R package! 52 | ######################## 53 | 54 | #install.packages('adagio') 55 | library(adagio) 56 | 57 | 58 | # single vector 59 | maxsub(v, inds = TRUE) 60 | 61 | 62 | 63 | # Standard example: Find a maximal sum submatrix 64 | A <- matrix(c(3,-2,-7,4, 9,2,-6,1, -10,2,-4,1, -5,7,2,-2),nrow = 4, ncol = 4, byrow =TRUE) 65 | 66 | maxsub2d(A) 67 | 68 | 69 | 70 | # Application to points in the unit square: 71 | set.seed(723) 72 | 73 | N <- 50; 74 | w <- rnorm(N) 75 | x <- runif(N); 76 | y <- runif(N) 77 | clr <- ifelse (w >= 0, "blue", "red") 78 | plot(x, y, pch = 20, col = clr, xlim = c(0, 1), ylim = c(0, 1)) 79 | 80 | xs <- unique(sort(x)); ns <- length(xs) 81 | X <- c(0, ((xs[1:(ns-1)] + xs[2:ns])/2), 1) 82 | ys <- unique(sort(y)); ms <- length(ys) 83 | Y <- c(0, ((ys[1:(ns-1)] + ys[2:ns])/2), 1) 84 | abline(v = X, col = "gray") 85 | abline(h = Y, col = "gray") 86 | 87 | A <- matrix(0, N, N) 88 | xi <- findInterval(x, X); yi <- findInterval(y, Y) 89 | for (i in 1:N) A[yi[i], xi[i]] <- w[i] 90 | 91 | msr <- maxsub2d(A) 92 | rect(X[msr$inds[3]], Y[msr$inds[1]], X[msr$inds[4]+1], Y[msr$inds[2]+1]) 93 | 94 | 95 | 96 | 97 | 98 | -------------------------------------------------------------------------------- /functions/Knapsack.R: -------------------------------------------------------------------------------- 1 | ## Knapsack 2 | 3 | knapsack <- function(values, weights, n, W) { 4 | m <- matrix(0, nrow = n + 1, ncol = W + 1) 5 | 6 | 7 | for (j in 1:W) { 8 | m[1, j] <- 0 9 | } 10 | 11 | for (i in 1:n) { 12 | m[i, 1] <- 0 13 | } 14 | 15 | 16 | for (i in 2:(n + 1)) { 17 | for (j in 1:(W + 1)) { 18 | if (weights[i - 1] > j) { 19 | m[i, j] <- m[i - 1, j] 20 | } else { 21 | m[i, j] <- max(m[i - 1, j], m[i - 1, j - weights[i - 1]] + values[i - 1]) 22 | } 23 | } 24 | } 25 | 26 | 27 | return(m[n + 1, W + 1]) 28 | } 29 | 30 | 31 | values <- c(3, 4, 5, 6) 32 | weights <- c(2, 3, 4, 5) 33 | n <- length(values) 34 | W <- 5 35 | result <- knapsack(values, weights, n, W) 36 | print(result) 37 | -------------------------------------------------------------------------------- /functions/L-Systems.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # L-System drawing for Turtle Graphics 4 | # Random walk 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #20 8 | # Created: February 16, 2021 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | 13 | # Changelog: 14 | # 15 | ########################################### 16 | 17 | library(TurtleGraphics) 18 | 19 | 20 | # common function 21 | turtlebump <- function(i, j) { 22 | if (i==0) { 23 | turtle_forward(10) 24 | } else { 25 | turtlebump(i-1, j) 26 | turtle_left(60) 27 | turtlebump(i-1, j) 28 | turtle_right(60) 29 | turtle_right(60) 30 | turtlebump(i-1, j) 31 | turtle_left(60) 32 | } 33 | } 34 | 35 | 36 | set.seed(2908) 37 | turtle_init(600, 500, "clip") 38 | turtle_hide() 39 | i <- 8 40 | j <- 500 41 | turtle_do({ 42 | turtle_up() 43 | turtle_left(90) 44 | turtle_forward(120) 45 | turtle_forward(120) 46 | turtle_right(60) 47 | turtle_right(60) 48 | turtle_right(60) 49 | turtle_down() 50 | turtlebump(i,j) 51 | }) 52 | 53 | ########################################### 54 | ########################################### 55 | ### Randomised L-System 56 | ########################################### 57 | ########################################### 58 | 59 | random_turtle <- function(){ 60 | 61 | f <- "" 62 | single_com <- function(){ 63 | list_com <- c("turtle_left(","turtle_right(") 64 | angle <- sample(1:120, 1, TRUE) 65 | com <- sample(list_com,1,TRUE) 66 | return(paste0(com, angle, ")\n")) 67 | } 68 | 69 | comm1 <- "set.seed(2908) 70 | turtle_init(600, 500, 'clip') 71 | turtle_hide() 72 | i <- 8 73 | j <- 500 74 | turtle_do({" 75 | 76 | for (i in 1:10){ 77 | sc <- single_com() 78 | #sc2 <- single_com2() 79 | i <- i + 1 80 | f <- paste(f, sc, collapse = NULL) 81 | #print(f) 82 | comm2 <<- f 83 | } 84 | 85 | comm3 <- " 86 | turtlebump(i,j) 87 | })" 88 | 89 | fin <- paste0(comm1, comm2, comm3) 90 | eval(parse(text=fin)) 91 | 92 | } 93 | 94 | #run random function 95 | random_turtle() 96 | -------------------------------------------------------------------------------- /functions/L-systems2.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | #### 3 | #### L-System 4 | #### 5 | ########################################## 6 | 7 | A <- matrix(c( 0 , 0 , 0 , 0.20), nrow=2); 8 | a = c(0, 0.00); 9 | pa = 0.01 10 | 11 | B <- matrix(c( 0.65, -0.10, 0, 0.80), nrow=2); 12 | b = c(0, 1.60); 13 | pb = 0.65 14 | 15 | C <- matrix(c( 0.20, 0.10, -0.26, 0.22), nrow=2); 16 | c = c(0, 1.60); 17 | pc = 0.05 18 | 19 | D <- matrix(c(-0.25, 0.25, 0.25, 0.25), nrow=2); 20 | d = c(0, 0.44); 21 | pd = 0.05 22 | 23 | K <- list(A, B, C, D) 24 | k <- list(a, b, c, d) 25 | N <- 5000 26 | 27 | s <- sample(1:4, N, prob = c(pa, pb, pc, pd), replace = TRUE) 28 | P <- matrix(0, nrow=2, ncol=N+1) 29 | 30 | for (i in seq(N)) { 31 | 32 | M = K[[s[i]]] 33 | m = k[[s[i]]] 34 | P[,i+2] = M %*% P[,i+1] + m+0.1 35 | } 36 | 37 | 38 | # Plot Matrix 39 | plot(P[1,], P[2,],as=2,pch='.',an=F,ax=F) 40 | -------------------------------------------------------------------------------- /functions/LetterFrequencyNumbers.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Letter frequency for numbers in a dataset 4 | # Series: 5 | # Little Useless-useful R functions #22 6 | # Created: March 21, 2021 7 | # Author: Tomaž Kaštrun 8 | # Blog: tomaztsql.wordpress.com 9 | # V.1.0 10 | # 11 | # Changelog: 12 | # words of numbers: 13 | # https://www.woodwardenglish.com/lesson/numbers-1-100-in-english/ 14 | ########################################### 15 | 16 | 17 | #function 18 | word_a_number <- function(numb){ 19 | 20 | basLet <- c('one','two','three','four','five','six','seven','eight','nine','ten' 21 | ,'eleven','twelve','thirteen','fourteen','fifteen','sixteen','seventeen','eighteen','nineteen' 22 | ,'twenty','thirty','forty','fifty','sixty','seventy','eighty','ninety','one hundred') 23 | basNum <- c(1:20,30,40,50,60,70,80,90,100) 24 | df <- data.frame(num = basNum, let = as.character(basLet)) 25 | 26 | if (numb <= 20) { 27 | im <- df[which(df$num == numb),]$let 28 | #print(paste(im, collapse = NULL)) 29 | } else { 30 | if (numb %% 10 == 0){ 31 | e <- df[which(df$num == numb),]$let 32 | #print(paste0(e, collapse=NULL)) 33 | } else { 34 | sec <- numb %% 10 35 | fir <- as.integer(numb/10)*10 36 | f_im <- df[which(df$num == fir),]$let 37 | s_im <- df[which(df$num == sec),]$let 38 | res <- paste0(f_im,"-",s_im, collapse = NULL) 39 | #print(res) 40 | } 41 | } 42 | } 43 | 44 | # run a single function 45 | word_a_number(87) 46 | 47 | 48 | #function for count the frequency 49 | freqLet <- function(x) { 50 | word <- tolower(unlist(strsplit(x,""))) 51 | word_table <- table(word) 52 | ans <- word_table[names(word_table)] 53 | } 54 | 55 | getFreq <- function(vect) { 56 | df <- data.frame(word=as.character(), stringsAsFactors = FALSE) 57 | for (i in 1:length(vect)) { 58 | df[i,1] <- as.character(word_a_number(i)) 59 | a <<- freqLet(df$word) 60 | } 61 | return(a) 62 | } 63 | 64 | ################################ 65 | #### Let's check the 66 | #### complete set of numbers 67 | ################################ 68 | 69 | # Automate the function, get a vector of first 100 numbers 70 | vect <- c(1:100) 71 | 72 | #Is there A in first 100 words? 73 | getFreq(vect) 74 | 75 | #quick visual 76 | plot(sort(a, decreasing = TRUE), type = "h", col = "red", lwd = 10, 77 | main = "Letter frequency in numbers", xlab = "Letters", ylab = "frequnecy of a letter") 78 | 79 | -------------------------------------------------------------------------------- /functions/Leveshtein.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # 4 | # Calcuate Levenshtein distance 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #43 8 | # Created: October 15, 2022 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | # 13 | # Changelog: 14 | # 15 | ########################################## 16 | 17 | a <- "tomaz" 18 | b <- "tone" 19 | len_a <- nchar(a) 20 | len_b <- nchar(b) 21 | 22 | 23 | 24 | 25 | Levenshtein_distance <- function(a,b){ 26 | len_a <- nchar(a) 27 | len_b <- nchar(b) 28 | 29 | if(len_a==0) return(len_b) 30 | if(len_b==0) return(len_a) 31 | if(len_a!=0 & len_b!=0){ 32 | if(substr(a,len_a,len_a)==substr(b,len_b,len_b)){ 33 | return (Recall(substr(a,1,len_a-1),substr(b,1,len_b-1)) ) 34 | } else { 35 | return(1+min( 36 | Recall(substr(a,1,len_a-1),b),Recall(a,substr(b,1,len_b-1)),Recall(substr(a,1,len_a-1),substr(b,1,len_b-1)) 37 | ) 38 | ) 39 | } 40 | } 41 | } 42 | 43 | #check distance 44 | Levenshtein_distance(a,b) 45 | 46 | 47 | -------------------------------------------------------------------------------- /functions/LoremIpsum.R: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/functions/LoremIpsum.R -------------------------------------------------------------------------------- /functions/MakingScatterPlotFromImage.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Making scatter plot from JPG 4 | # Series: 5 | # Little Useless-useful R functions #9 6 | # Created: November 19, 2020 7 | # Author: Tomaz Kastrun 8 | # Blog: tomaztsql.wordpress.com 9 | # V.1.0 10 | 11 | # Changelog: - 12 | 13 | # Disclaimer - All functions from this series 14 | # are written for base package; this uses also 15 | # magick and ggplot2 16 | ########################################### 17 | 18 | library(ggplot2) 19 | library(magick) 20 | 21 | 22 | setwd("/Users/tomazkastrun/Documents/GitHub/Useless_R_functions/") 23 | 24 | 25 | img <- magick::image_read("image/nikeLogo.jpg") 26 | img <- img %>% 27 | image_quantize(max=2, colorspace = 'gray', dither=TRUE) %>% 28 | image_scale(geometry = geometry_size_pixels(width=25, height=20, preserve_aspect=FALSE)) 29 | 30 | 31 | # Image manipulation 32 | mat <- t(1L - 1L * (img[[1]][1,,] > 180)) 33 | mat_df <-data.frame(mat) 34 | 35 | 36 | 37 | # Melt data 38 | dff <- data.frame(x = NULL, y = NULL) 39 | for (i in 1:nrow(mat_df)) { 40 | for (j in 1:ncol(mat_df)){ 41 | if (mat_df[i,j] == 1){ 42 | d <- data.frame(x=i, y=j) 43 | dff <<- rbind(dff, d) 44 | } 45 | } 46 | } 47 | 48 | # draw scatter 49 | g <- ggplot(dff, aes(x = x, y = y)) + geom_point() + scale_x_reverse() + coord_flip() 50 | g + theme(panel.background = element_rect(fill = "white", colour = "grey")) 51 | 52 | #draw scatter with jitter 53 | g <- ggplot(dff, aes(x = x, y = y)) + geom_point() + geom_jitter() + scale_x_reverse() + coord_flip() 54 | g + theme(panel.background = element_rect(fill = "white", colour = "grey")) 55 | 56 | # draw scatter with smooth and CI 57 | g <- ggplot(dff, aes(x = x, y = y)) + geom_point() + scale_x_reverse() + coord_flip() + geom_smooth() 58 | g + theme(panel.background = element_rect(fill = "white", colour = "grey")) 59 | 60 | 61 | #Cleanup 62 | rm(d,dff,g,mat,mat_df,i,j,im) 63 | -------------------------------------------------------------------------------- /functions/MandelbrotSet.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # The Mandelbrot set 4 | # 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #43 8 | # Created: Jauary 04, 2023 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | # 13 | # Changelog: 14 | # 15 | ########################################## 16 | 17 | 18 | MandelBrotImage <- function(){ 19 | 20 | cols <- colorRampPalette(c("white","black","white","grey","black"))(11) 21 | n <- 400 22 | 23 | # variables 24 | x <- seq(-2, 1, length.out=250) 25 | y <- seq(-1.5, 1.5, length.out=250) 26 | c <- outer(x,y*1i,"+") 27 | z <- matrix(0.0, nrow=length(x), ncol=length(y)) 28 | k <- matrix(0.0, nrow=length(x), ncol=length(y)) 29 | 30 | 31 | for (rep in 1:n) { 32 | for (i in 1:250) { 33 | for (j in 1:250) { 34 | if(Mod(z[i,j]) < 2 && k[i,j] < n) { 35 | z[i,j] <- z[i,j]^2 + c[i,j] 36 | k[i,j] <- k[i,j] + 1 37 | } 38 | } 39 | } 40 | } 41 | 42 | image(x,y,k, col=cols, axes = FALSE, xlab = "" , ylab = "" ) 43 | } 44 | 45 | 46 | # run function 47 | MandelBrotImage() 48 | -------------------------------------------------------------------------------- /functions/MergeR_SQLJoin.R: -------------------------------------------------------------------------------- 1 | 2 | ########################################## 3 | # 4 | # Comparing MERGE R Method with 5 | # T-SQL JOIN Clause 6 | # 7 | # Series: 8 | # Little Useless-useful R functions #35 9 | # Created: April 15, 2022 10 | # Author: Tomaz Kastrun 11 | # Blog: tomaztsql.wordpress.com 12 | # V.1.0 13 | 14 | # Changelog: 15 | # 16 | ########################################### 17 | 18 | 19 | Users = data.frame(UserID = c(1,1,2,2,3,4) 20 | ,GroupID = c("X","X","Y","Y","X","Z") 21 | ,DateCreated = c("2022-04-10","2022-04-11","2022-04-13","2022-04-14","2022-04-11","2022-04-13") 22 | ,TotalKM = c(22,33,33,42,6,8) 23 | ,Age = c(34,34,41,41,18,56) 24 | ) 25 | 26 | UserRun = data.frame(UserID = c(1,1,2,2,3,4,5) 27 | ,GroupID = c("X","X","Y","Y","X","Z","T") 28 | ,Run = c(1,0,0,0,0,0,0) 29 | ,RunName = c("Short", "Over Hill","Short","Miller","River","Mountain top","City") 30 | 31 | ) 32 | 33 | 34 | ## joins 35 | 36 | # inner join 37 | IJ_Us_UsR <- merge(x=Users, y=UserRun, by = c("UserID", "GroupID")) 38 | 39 | 40 | # Left join all.x = TRUE 41 | LJ_Us_UsR <- merge(x = Users, y = UserRun, by = c("UserID", "GroupID") , all.x = TRUE) 42 | LJ_Us_UsR <- merge(x = UserRun, y = Users, by = c("UserID", "GroupID") , all.y = TRUE) 43 | 44 | 45 | #right join all.x = TRUE 46 | RJ_Us_UsR <- merge(x = Users, y = UserRun, by = c("UserID", "GroupID") , all.y = FALSE) 47 | 48 | 49 | # Cross JOIN 50 | CJ_Us_UsR <- merge(x = Users, y = UserRun, by = NULL ) 51 | 52 | # Join by Row Names / Internal uniequefier 53 | RowNameJ_Us_UsR <- merge(x=Users, y=UserRun, by = "row.names") 54 | ## Alternative 55 | ## RowNameJ_Us_UsR <- merge(x=Users, y=UserRun, by = 0) 56 | 57 | 58 | # Joining more than two data.frames 59 | Run = data.frame(UserID = c(1,1,2,2,3,4,6,8) 60 | ,GroupID = c("X","X","Y","Y","X","Z","H","K") 61 | ,Trainer = c(1,1,1,1,1,0,0,0) 62 | ) 63 | 64 | 65 | merge(merge(x=Users, y=UserRun, by = c("UserID", "GroupID")), y=Run, by.y = c("UserID", "GroupID")) 66 | 67 | 68 | 69 | ####################### 70 | ##### SQL Code ######## 71 | ####################### 72 | # 73 | # DROP TABLE dbo.Users 74 | # DROP TABLE dbo.UserRun 75 | # 76 | # CREATE TABLE dbo.Users ( 77 | # UserID INT 78 | # ,GroupID CHAR(1) 79 | # ,DateCreated datetime 80 | # ,TotalKM INT 81 | # ,Age INT 82 | # ) 83 | # 84 | # CREATE TABLE dbo.UserRun ( 85 | # UserID INT 86 | # ,GroupID CHAR(1) 87 | # ,Run INT 88 | # ,RunName VARCHAR(50) 89 | # ) 90 | # 91 | # INSERT INTO dbo.Users 92 | # SELECT 1, 'X','2022/04/10',22,34 93 | # UNION ALL SELECT 1, 'X','2022/04/11',33,34 94 | # UNION ALL SELECT 1, 'X','2022/04/12',33,34 95 | # UNION ALL SELECT 2, 'Y','2022/04/13',33,41 96 | # UNION ALL SELECT 2, 'Y','2022/04/14',42,41 97 | # UNION ALL SELECT 3, 'X','2022/04/11',6,18 98 | # UNION ALL SELECT 4, 'Z','2022/04/13',8,56 99 | # 100 | # INSERT INTO dbo.UserRun 101 | # SELECT 1, 'X',1,'Short' 102 | # UNION ALL SELECT 1, 'X',0,'Over Hill' 103 | # UNION ALL SELECT 2, 'Y',0,'Short' 104 | # UNION ALL SELECT 2, 'Y',0,'Miller' 105 | # UNION ALL SELECT 3, 'X',0,'River' 106 | # UNION ALL SELECT 4, 'Z',0,'Mountain top' 107 | # UNION ALL SELECT 5, 'T',0,'City' 108 | # 109 | # 110 | # 111 | # SELECT 112 | # * 113 | # FROM dbo.Users as U 114 | # INNER JOIN dbo.UserRun AS UR 115 | # ON U.UserID = UR.UserID 116 | # AND U.GroupID = UR.GroupID 117 | # 118 | # 119 | # SELECT 120 | # * 121 | # FROM dbo.UserRun as U 122 | # LEFT JOIN dbo.Users AS UR 123 | # ON U.UserID = UR.UserID 124 | # AND U.GroupID = UR.GroupID 125 | # 126 | # 127 | # SELECT * FROM users 128 | # SELECT * FROM userrun 129 | 130 | 131 | 132 | 133 | -------------------------------------------------------------------------------- /functions/MicrosoftLogo.R: -------------------------------------------------------------------------------- 1 | 2 | ################# 3 | # microsoft logo 4 | ################# 5 | library(ggplot2) 6 | 7 | #### Logo 8 | ggplot()+ 9 | geom_rect(aes(xmin=1,xmax=3,ymin=10,ymax=15),fill="#05a6f0")+ 10 | geom_rect(aes(xmin=1,xmax=3,ymin=15,ymax=20),fill="#f35426")+ 11 | geom_rect(aes(xmin=3,xmax=5,ymin=10,ymax=15),fill="#ffba08")+ 12 | geom_rect(aes(xmin=3,xmax=5,ymin=15,ymax=20),fill="#81bc06")+ 13 | theme_void() 14 | 15 | 16 | -------------------------------------------------------------------------------- /functions/MixedCases.R: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/functions/MixedCases.R -------------------------------------------------------------------------------- /functions/NumberCountdownGame.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Script that finds a solution for 4 | # Number countdown game 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #16 8 | # Created: January 10, 2021 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | 13 | # Changelog: 14 | # 15 | ########################################### 16 | 17 | #install.packages("RcppAlgos") 18 | library(RcppAlgos) 19 | 20 | 21 | countDown_puzzle <- function(six, res_num) { 22 | oper <- c("+","-","/","*") 23 | res <- 0 24 | d2 <- permuteGeneral(six) 25 | for (i in 1:nrow(d2)){ 26 | for (o in 1:1000){ 27 | 28 | r <- paste0(as.integer(d2[i,1]),' ',as.character(sample(oper,1)),' (',as.integer(d2[i,2]),' ',as.character(sample(oper,1)),' ((', 29 | as.integer(d2[i,3]),' ',as.character(sample(oper,1)),as.integer(d2[i,4]),') ',as.character(sample(oper,1)), 30 | as.integer(d2[i,5]),') ',as.character(sample(oper,1)),as.integer(d2[i,6]), ') ', sep ="") 31 | #print(r) 32 | res <- eval(parse(text=r)) 33 | if(res == res_num){ 34 | print(paste0("Solution: ", r, ' with result of: ', res, ' for given the numbers: ', paste(six, collapse = " "), sep="")); 35 | 36 | } 37 | } 38 | } 39 | } 40 | 41 | 42 | ################################################### 43 | # run function with given six numbers and solution 44 | ################################################## 45 | 46 | #countDown_puzzle(c(9,8,50,2,11,200), 352) 47 | #countDown_puzzle(c(11,50,75,8,3,25), 544) 48 | #countDown_puzzle(c(25,5,11,7,8,2), 768) 49 | countDown_puzzle(c(100,9,10,4,1,8), 594) 50 | 51 | 52 | ############################################# 53 | # or generate the numbers and random solution 54 | ############################################# 55 | number_pool <- c(1:11, 25, 50, 75, 100, 200) 56 | six <- sample(number_pool, 6, replace=FALSE) 57 | res_num <- sample(100:999,1) 58 | 59 | countDown_puzzle(six, res_num) 60 | 61 | 62 | 63 | -------------------------------------------------------------------------------- /functions/PackageFrequencies.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Frequency of same functions in vignettes / libraries 4 | # Series: 5 | # Little Useless-useful R functions #8 6 | # Created: November 11, 2020 7 | # Author: Tomaz Kastrun 8 | # Blog: tomaztsql.wordpress.com 9 | # V.1.0 10 | 11 | # Changelog: - 12 | ########################################### 13 | 14 | 15 | funkyFun <- function(){ 16 | libnames <- installed.packages()[,1] 17 | #exclude packages: 18 | libnames <- libnames[ !(libnames %in% c("rJava","RPostgreSQL","XLConnect","xlsx","xlsxjars")) ] 19 | df <- data.frame(packname = NULL, funkyName = c(NULL,NULL)) 20 | #for (i in 1:50){ 21 | for (i in 1:length(libnames)){ 22 | com <- paste0("require(", libnames[i],")") 23 | eval(parse(text= com)) 24 | str <- paste0("package:", libnames[i]) 25 | funk <- (ls(str)) 26 | if (length(funk)==0){ 27 | funk <- ifelse((length(funk)==0)==TRUE, "funkyFun", funk) 28 | } 29 | da <- cbind(libnames[i], funk) 30 | df <- rbind(df, da) 31 | 32 | } 33 | no_freq <- data.frame(table(df$funk)) 34 | all_duplicated_functions <- no_freq[no_freq$Freq > 1,] 35 | all_duplicated_functions_per_package <- df[df$funk %in% no_freq$Var1[no_freq$Freq > 1],] 36 | all_duplicated_functions_per_package2 <<- df[df$funk %in% no_freq$Var1[no_freq$Freq > 1],] 37 | return(all_duplicated_functions_per_package) 38 | } 39 | 40 | ######################################## 41 | ##### run with warnings seen 42 | ##### Otherwise uncomment next 3 lines 43 | ######################################## 44 | 45 | #oldvalueWarning <- getOption("warn") 46 | #options(warn = -1) 47 | funkyFun() 48 | #options(warn = oldvalueWarning) 49 | 50 | -------------------------------------------------------------------------------- /functions/Pipe4ggplot2.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Pipe - a nested function for chain of 4 | # piped ggplot2 function calls 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #19 8 | # Created: February 12, 2021 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | 13 | # Changelog: 14 | # 15 | ########################################### 16 | 17 | library(ggplot2) 18 | library(dplyr) 19 | library(rlang) 20 | 21 | #sample DataSet 22 | iris <- iris 23 | ggplot(iris, aes(Sepal.Length, Sepal.Width, colour = Species)) + geom_point() + theme_bw() 24 | 25 | 26 | #Pipe function 27 | ToPipe <- function(ee) { 28 | this_fn <- rlang::call_name(ee) 29 | updated_args <- rlang::call_args(ee) %>% map(ToPipe) 30 | 31 | if (identical(this_fn, "%>%") || length(updated_args)==0) { 32 | fn_2 <- rlang::call2("+", !!!updated_args) 33 | eval(fn_2) 34 | } else { 35 | arg1 <- updated_args[[1]] 36 | other_args <- updated_args[-1] 37 | fn_3 <- rlang::call2(as.name("+"), arg1, rlang::call2(this_fn, !!!other_args) ) 38 | eval(fn_3) 39 | } 40 | } 41 | 42 | 43 | 44 | ### pipe version 45 | fun <- quote(ggplot(iris, aes(Sepal.Length, Sepal.Width, colour = Species)) 46 | %>% geom_point() 47 | %>% theme_bw()) 48 | ToPipe(fun) 49 | 50 | 51 | this_fn <- rlang::call_name(fun) 52 | updated_args <- rlang::call_args(fun) 53 | 54 | if (identical(this_fn, "%>%") || length(updated_args)==0) { 55 | fn_2 <- rlang::call2("+", !!!updated_args) 56 | eval(fn_2) 57 | } else { 58 | arg1 <- updated_args[[1]] 59 | other_args <- updated_args[-1] 60 | fn_3 <- rlang::call2(as.name("+"), arg1, rlang::call2(this_fn, !!!other_args) ) 61 | eval(fn_3) 62 | } 63 | -------------------------------------------------------------------------------- /functions/Plot_showcase.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Showcase of base plot function 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #29 7 | # 8 | # Created: October 15, 2021 9 | # Author: Toma? Ka?trun 10 | # Blog: tomaztsql.wordpress.com 11 | 12 | # Change log: 13 | 14 | ########################################### 15 | 16 | # clean environment 17 | rm(list = ls(all.names = TRUE)) 18 | dev.off(dev.list()["RStudioGD"]) 19 | graphics.off() 20 | 21 | 22 | library(magick) 23 | 24 | set.seed(2908) 25 | 26 | 27 | plot_animation <- function(SavePath){ 28 | 29 | # create a temporary directory to store plot files 30 | dir_out <- file.path(tempdir(), "ShowCaseTempFolder") 31 | dir.create(dir_out, recursive = TRUE) 32 | 33 | # general data 34 | AllData <- data.frame(graph=c 35 | ( 36 | "plot(ScatterData, main = 'Scatterplot')" 37 | ,"plot(BarData, main = 'Histogram')" 38 | ,"plot(BarData, rnorm(150), main = 'Boxplot')" 39 | ,"plot(TimeSeriesData, main = 'Time-series')" 40 | ,"plot(FunctionData, -10, 5*pi, main = 'Plot a function')" 41 | ,"plot(IrisData, main = 'Correlation plot for two variables')" 42 | ,"plot(IrisData, main = 'Correlation plot for two variables with lines of SS') 43 | lines(lowess(iris[,1:2]))" 44 | ,"plot(IrisData3, main = 'Correlation plot for three or more')" 45 | 46 | ), 47 | data=c('ScatterData <- cbind(rnorm(200),rnorm(200) * 48 | rnorm(200) + rnorm(200))' 49 | ,'BarData <- factor(iris$Sepal.Width)' 50 | ,'BarData <- factor(iris$Sepal.Width)' 51 | ,'TimeSeriesData <- ts(matrix(rnorm(300), 52 | nrow = 300, ncol = 1), start = c(1990, 1), 53 | frequency = 12)' 54 | ,'FunctionData <- function(x) {x^4*pi}' 55 | ,'IrisData <- as.data.frame(iris[, 1:2])' 56 | ,'IrisData <- as.data.frame(iris[, 1:2])' 57 | ,'IrisData3 <- as.data.frame(iris[, 1:3])' 58 | ) 59 | ) 60 | 61 | 62 | for (i in 1:nrow(AllData)) { 63 | graphinfo <- as.character(AllData$graph[i]) 64 | datainfo <- as.character(AllData$data[i]) 65 | eval(parse(text=datainfo)) 66 | name_p <- paste0(dir_out,'\\',i,'.png') 67 | png(name_p) 68 | par(mfrow=c(3,1)) 69 | p <- eval(parse(text=graphinfo)) 70 | 71 | plot(c(0, 1), c(0, 1), ann = FALSE, bty = 'n', type = 'n', xaxt = 'n', yaxt = 'n') 72 | text(x = 0.5, y = 0.5, paste("Graph code: ", graphinfo), cex = 1.5, col = "Darkgreen", font=1, adj=0.5) 73 | 74 | plot(c(0, 1), c(0, 1), ann = FALSE, bty = 'n', type = 'n', xaxt = 'n', yaxt = 'n') 75 | text(x = 0.5, y = 0.5, paste("Data script: ",datainfo), cex = 1.5, col = "Darkblue", font=1, adj=0.5) 76 | 77 | par(mfrow=c(1,1)) 78 | dev.off() 79 | } 80 | 81 | 82 | # Render animation and store to disk 83 | plot_animation <- image_animate(image_join(lapply(list.files(dir_out, full.names = TRUE), image_read)), fps = 0.5) 84 | image_write(image = plot_animation,path = SavePath) 85 | unlink(dir_out, recursive=TRUE) 86 | 87 | } 88 | 89 | # Mqke sure access is granted 90 | Store_path <- 'c:\\Users\\tomaz\Dekstop\ShowCase.gif' #windows 91 | Store_path <- '/Users/tomaz/Dekstop/ShowCase.gif' #unix 92 | plot_animation(Store_path) 93 | -------------------------------------------------------------------------------- /functions/Plotting_photos.R: -------------------------------------------------------------------------------- 1 | 2 | ########################################## 3 | # 4 | # Converting JPG and plots raster using 5 | # horizontal violins 6 | # 7 | # Series: 8 | # Little Useless-useful R functions #33 9 | # Created: January 29, 2022 10 | # Author: Tomaz Kastrun 11 | # Blog: tomaztsql.wordpress.com 12 | # V.1.0 13 | 14 | # Changelog: 15 | # 16 | ########################################### 17 | 18 | 19 | ## Plotting photos 20 | 21 | # Libraries 22 | pkg <- c("dplyr", "tidyr", "ggplot2", "magick", "stringr", 23 | "forcats", "viridis", "grid", "purrr","hrbrthemes") 24 | lapply(pkg, require, character.only = TRUE) 25 | 26 | 27 | setwd("/Users/tomazkastrun/Documents/tomaztk_github/Useless_R_functions") 28 | 29 | img <- magick::image_read("image/appleLogo.jpg") 30 | img <- img %>% 31 | image_quantize(max=2, colorspace = 'gray', dither=TRUE) %>% 32 | image_scale(geometry = geometry_size_pixels(width=50, height=15, preserve_aspect=FALSE)) 33 | 34 | # Image manipulation 35 | mat <- t(1L - 1L * (img[[1]][1,,] > 180)) 36 | mat_df <-data.frame(mat) 37 | 38 | 39 | # Transpose data 40 | dff <- data.frame(x = NULL, y = NULL) 41 | for (i in 1:nrow(mat_df)) { 42 | for (j in 1:ncol(mat_df)){ 43 | if (mat_df[i,j] == 1){ 44 | d <- data.frame(x=i, y=j) 45 | dff <<- rbind(dff, d) 46 | } 47 | } 48 | } 49 | 50 | # Creating factors 51 | dff$x <- str_pad(as.character(dff$x), 3, pad = "0") 52 | 53 | # Reversing order 54 | df <- dff %>% 55 | mutate(x = fct_rev(fct_reorder(x,y))) %>% 56 | purrr::map_df(rev) 57 | 58 | df2 <- dff %>% mutate(x = fct_rev(fct_reorder(x,y))) 59 | df3 <- data.frame(x = as.character(df2$x), y = df$y) 60 | 61 | 62 | vp <- df3 %>% 63 | ggplot( aes(x=x, y=y, fill=x, color=y)) + 64 | geom_violin(width=1.5, size=0.2) + 65 | scale_fill_viridis(discrete=TRUE) + 66 | scale_color_viridis(discrete=TRUE) + 67 | theme_void() 68 | 69 | print(vp, vp=viewport(angle=-90)) 70 | -------------------------------------------------------------------------------- /functions/PsychedelicSquareRoot.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Useless and Psychedelic x11 and square 4 | # root visualization 5 | # Series: 6 | # Little Useless-useful R functions #4 7 | # Created: October 25, 2020 8 | # Author: Tomaž Kaštrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | 12 | # Changelog: 13 | ########################################### 14 | require(RColorBrewer) 15 | 16 | 17 | Psychedelics <- function(number_iterations) 18 | { 19 | for (i in 1:number_iterations){ 20 | x <- seq(-5*pi, 5*pi, length.out = runif(1, i*2, i*2+1)) 21 | y <- seq(-5*pi, 5*pi, length.out = i) 22 | # print(x) print(y) 23 | r <- sqrt(outer(x^2, y^2, "+")) 24 | # print(r) 25 | image(z = exp(-r/8)*cos(r^4), col = brewer.pal(12,"Set3"), xaxt='n', yaxt='n', ann=FALSE) 26 | Sys.sleep(0.1) 27 | } 28 | } 29 | 30 | 31 | ## Run all together - when running on Unix / Windows 32 | ## screen size can be altered 33 | x11(width = 7,height = 7) 34 | Psychedelics(25) 35 | graphics.off() 36 | -------------------------------------------------------------------------------- /functions/QR-Code_time.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # QR-Code Clock 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #67 7 | # Created: January 08, 2035 8 | # Author: Tomaz Kastrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | 12 | # Changelog: 13 | ########################################### 14 | 15 | 16 | 17 | library(qrcode) 18 | 19 | 20 | while (Sys.time()+1 > Sys.time()){ 21 | n_o_w <- paste0("Current time is ",as.character(format(Sys.time(), "%X"))) 22 | print(n_o_w) 23 | qr_code(n_o_w, ecl = "M" ) |> 24 | plot() 25 | Sys.sleep(10) 26 | } 27 | 28 | 29 | 30 | # creating animation 31 | 32 | library(gganimate) 33 | 34 | getwd() 35 | setwd("/Users/tomazkastrun/Documents/tomaztk_github/Useless_R_functions/figures") 36 | 37 | for (i in 1:10){ 38 | n_o_w <- paste0("Current time is ",as.character(format(Sys.time(), "%X"))) 39 | print(n_o_w) 40 | qr <- qr_code(n_o_w, ecl = "M" ) 41 | filename <- paste0("QRCode", i, ".png") 42 | png(filename) 43 | plot(qr) 44 | dev.off() 45 | Sys.sleep(1) 46 | } 47 | 48 | library(magick) 49 | 50 | files <- c("QRCode1.png", "QRCode2.png", "QRCode3.png", "QRCode4.png", "QRCode5.png", "QRCode6.png", "QRCode7.png", "QRCode8.png", "QRCode9.png", "QRCode10.png") 51 | images <- image_read(files) 52 | animation <- image_animate(images, fps = 1) 53 | image_write(animation, "QRCode_animation.gif") 54 | -------------------------------------------------------------------------------- /functions/R-squared.R: -------------------------------------------------------------------------------- 1 | 2 | # R-squared useful over R-squared useless 3 | 4 | set.seed(2908) 5 | 6 | # some toy/random data 7 | x <- 1:30 8 | y <- 2 + 0.5*x + rnorm(30,0,4) 9 | mod <- lm(y~x) 10 | summary(mod)$r.squared 11 | 12 | 13 | 14 | # R-squared (coefficient of determination) is 15 | # also sum of squared residuals (fitted-value deviations) (mms) 16 | # over total sum of squared (tts) 17 | 18 | f <- mod$fitted.values # extract fitted (or predicted) values from model 19 | mss <- sum((f - mean(f))^2) 20 | tss <- sum((y - mean(y))^2) 21 | mss/tss 22 | 23 | #check 24 | all.equal(summary(mod)$r.squared , mss/tss ) 25 | 26 | 27 | # R-squared and demonstrate them with simulations in R. 28 | # Assuming: 1. R-squared doesn't necessarily mean measure goodness of fit. 29 | # It can be arbitrarily low when the model is completely correct. By making sigma2 large 30 | # large, we drive R-squared towards 0, even when every assumption of the simple linear regression model is correct in every particular. 31 | 32 | useless_r2_with_sigma <- function(sig){ 33 | x <- seq(1,10,length.out = 100) 34 | y <- 2 + 1.2*x + rnorm(100,0,sd = sig) # adding some random noise to function 35 | summary(lm(y ~ x))$r.squared 36 | } 37 | 38 | # plot shows sinking sigmas (starting with 1) where R2=1 and the model is completely wrong, respectively. 39 | 40 | assumption_sigma <- seq(0.5,20,length.out = 100) 41 | results <- sapply(assumption_sigma, useless_r2_with_sigma) # apply our function to a series of sigma values 42 | plot(results ~ assumption_sigma, type="b") 43 | 44 | 45 | 46 | set.seed(2908) 47 | x <- rexp(80,rate=0.005) # our predictor is data from an exponential distribution 48 | y <- (x-1)^2 * runif(80, min=0.8, max=1.2) # non-linear data generation 49 | plot(x,y) 50 | 51 | 52 | # check R squared 53 | summary(lm(y ~ x))$r.squared 54 | 55 | ### tule gre mal čau... 56 | # R-squared says nothing about prediction error, even with 57 | # exactly the same, and no change in the coefficients. 58 | # R-squared can be anywhere between 0 and 1 just by changing the range of X. 59 | # We're better off using Mean Square Error (MSE) as a measure of prediction error. 60 | 61 | set.seed(2908) 62 | x <- seq(1,10,length.out = 200) 63 | y <- 2 + 1.2*x + rnorm(200,0,sd = 0.9) #sd = 0.9 64 | mod1 <- lm(y ~ x) 65 | summary(mod1)$r.squared 66 | # [1] 0.9250846 67 | 68 | # calculate MSE 69 | sum((fitted(mod1) - y)^2)/200 70 | # [1] 0.7815316 71 | 72 | # changing the range 73 | set.seed(2908) 74 | 75 | #getting different R2 76 | x <- seq(1,3,length.out = 200) 77 | 78 | y <- 2 + 1.2*x + rnorm(200,0,sd = 0.9) 79 | mod1 <- lm(y ~ x) 80 | summary(mod1)$r.squared 81 | # [1] 0.3645032 82 | 83 | #but MSE is the same 84 | sum((fitted(mod1) - y)^2)/200 85 | # [1] 0.7815316 86 | 87 | 88 | # The R2 falls from 0.92 to 0.36 but the MSE is practically unchanged! 89 | # add plot 90 | 91 | # 4. R-squared cannot be compared between a model with untransformed Y and one with transformed Y, or 92 | # between different transformations of Y. R-squared can easily go down when the model assumptions are better fulfilled. 93 | 94 | x <- seq(1,3,length.out = 200) 95 | set.seed(2908) 96 | y <- exp(-2 - 0.09*x + rnorm(100,0,sd = 2.5)) 97 | summary(lm(y ~ x))$r.squared 98 | 99 | # and plot: 100 | 101 | plot(lm(y ~ x), which=3) 102 | 103 | 104 | # R is low 105 | 106 | plot(lm(log(y)~x),which = 3) 107 | 108 | summary(lm(log(y)~x))$r.squared 109 | 110 | # 5. It is very common to say that R-squared is "the fraction of variance explained" by the regression. 111 | # [Yet] if we regressed X on Y, we'd get exactly the same R-squared. 112 | # This in itself should be enough to show that a high R-squared says nothing about explaining one variable by another. 113 | 114 | x <- seq(1,10,length.out = 200) 115 | y <- 2 + 1.2*x + rnorm(100,0,sd = 2) 116 | summary(lm(y ~ x))$r.squared 117 | -------------------------------------------------------------------------------- /functions/RJobTitleGenerator.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Useless (and Quarky) R Job Title Generator 4 | # Series: 5 | # Little Useless-useful R functions #3 6 | # Created: October 24, 2020 7 | # Author: Tomaž Kaštrun 8 | # Blog: tomaztsql.wordpress.com 9 | # V.1.0 10 | 11 | # Changelog: 12 | ########################################### 13 | 14 | RJobTitle <- function(){ 15 | 16 | ### Values 17 | Fancystuff = c( 'Regional','Only the best','Insane','Qualitative','Virtuous','Senior' 18 | ,'Junior','In-House','Outsourced','Magnificent','Evolutionary','Customer orientated','Product' 19 | ,'Dynamic','Corporate Lead','Legacy','Investor','Direct','International','Over-seas','Internal','Human' 20 | ,'Creative','Volunteer','Lead','4 Stages of','Complete','Most Advanced','State of the art','Super high' 21 | ,'First Class','Powerful','Data','Head of','Master of','Chief of','Officer','Lead','Special') 22 | 23 | RStuff <- c('CRAN Lover','R Environment','userR! conference','R Package','Lattice','Graphics','Factors','Probability distribution' 24 | ,'Sampling','Vectors and numbers','package dependencies','Set.seed','Visualization','Data manipulation','Machine Learning' 25 | ,'Plot.ly','Shiny','Sys.getenv','Lubridate','NA','NaN','Environment history','R Script Editor','S3 Class' 26 | ,'Box Plot','Infix Operator','Parametrization','Slow Script','Long running Script','R ggplot library','Statistical Models' 27 | ,'%>% clause','R WHILE loop','Kronecker product','Matching operator','Integer division','dplyr and data.table' ) 28 | 29 | 30 | Roles = c('Analyst','Project Manager','Expert','Manager','Programmer','Artist' 31 | ,'Tamer','Developer','Wrangler','DataFramer','Statistician','Philosopher','ggPlotter' 32 | ,'Data Manipulator','tEvangelist','Hero','Guru','partz professional','Composer','Reader','Outliner' 33 | ,'Proof-reader','zoo Assistant','data.frame Operator','Matrix Maker','dpylr lover' 34 | ,'Tester','Deep tester','Backward tester','Office hater','Hollister','Warrior','Junkie' 35 | ,'Wizard','Leader','King','Github Approver','CARET Engineer','e1071 Architect','Rockstar','Ninja','R Coder' 36 | ,'Python Hater','Ninja','Captain','Strategist','Consultant','Counsellor','Organizer' 37 | ,'Emacs Endorser','Dog','Library Installer','Cheever','RStudio specialist','R Fanboy','Functionist' 38 | ,'Researcher','Shadower','Variable lover','Knitter Helper','Debugger','Data Scientists' 39 | ,'Statistician','Coffee Addict','Tidyverser','Knitter' 40 | ,'R-Studio dispatcher','Advanced Copy/paster','R-Bloggers subscriber','Markdown Writter' ) 41 | 42 | 43 | ### Ordering of subsets and generating R Job Title 44 | RTitle <- paste(sample(Fancystuff,1, replace=TRUE),sample(RStuff,1, replace=TRUE),sample(Roles,1, replace=TRUE), sep= " ") 45 | RTitle <- paste("Your Greatest of them greatest made-up R job title is: ", RTitle) 46 | return(RTitle) 47 | 48 | } 49 | 50 | #Run the script 51 | RJobTitle() 52 | -------------------------------------------------------------------------------- /functions/R_dataFrame_to_Python_Dataframe.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Export R Data.frame schema and data to 4 | # external file for Python Pandas 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #15 8 | # Created: January 04, 2021 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | # Changelog: 13 | # 14 | ########################################### 15 | 16 | 17 | ## goal: Python Dictionary 18 | ## d = {'col1': [1, 2], 'col2': [3, 4]} 19 | 20 | 21 | RtoPy <- function(df_input, filename_path) { 22 | 23 | # column names and number of rows 24 | Nn <- names(df_input) 25 | nr <- nrow(df_input) 26 | 27 | #Python is Indentation sensitive - leave these two lines without indentation 28 | py_df <- "import pandas as pd 29 | d = {" 30 | 31 | for (x in 1:length(Nn)){ 32 | var <- (Nn[x]) 33 | #Column Names 34 | py_df <- paste0(py_df, "'",var,"':[", collapse=NULL) 35 | 36 | #Data Rows 37 | for (i in 1:nr) { 38 | val <- df_input[i,x] 39 | #Check for data type 40 | if (sapply(df_input[i,x], class) == "factor") { 41 | py_df <- paste0(py_df, "'",val,"'", ",", collapse=NULL) 42 | #for last value in a column 43 | if (i == nr){ 44 | py_df <- paste0(py_df, "'",val,"'", "],","\n", collapse=NULL) 45 | } 46 | } else { 47 | py_df <- paste0(py_df, val, ",", collapse=NULL) 48 | #for last value in a column 49 | if (i == nr){ 50 | py_df <- paste0(py_df, val, "],","\n", collapse=NULL) 51 | } 52 | } 53 | 54 | } 55 | if (x == length(Nn)){ 56 | py_df <- substr(py_df, 1, nchar(py_df)-2) 57 | py_df <- paste0(py_df, "} 58 | df=pd.DataFrame(data=d)", collapse=NULL) 59 | } 60 | } 61 | 62 | ## Store to file 63 | sink(file = filename_path) 64 | cat(py_df) 65 | sink(file = NULL) 66 | } 67 | 68 | 69 | 70 | # Get the data from R data.frame to Python Pandas script 71 | iris <- iris 72 | iris <- data.frame(iris[1:15,]) 73 | RtoPy(iris, "/users/tomazkastrun/desktop/iris_py.txt") 74 | -------------------------------------------------------------------------------- /functions/R_fibonacci_benchmarks.R: -------------------------------------------------------------------------------- 1 | library(numbers) 2 | 3 | # number of folds 4 | n <- 10 5 | 6 | fib1 <- function(n){ 7 | res <- 0 8 | if (n == 1 | n == 2) {res <- 1} 9 | if (n >= 3) {res <- fib1(n-1) + fib1(n-2) } 10 | #return (res) 11 | res_fib1 <<- res 12 | } 13 | 14 | 15 | 16 | fib2 <- function(n) { 17 | if(n <= 1) { 18 | return(n) 19 | } else { 20 | #return(fib2(n-1) + fib2(n-2)) 21 | res_fib2 <<- fib2(n-1) + fib2(n-2) 22 | } 23 | } 24 | 25 | 26 | 27 | fib3 <- function(n){ 28 | 29 | fibvals <- numeric(n) 30 | fibvals[1] <- 1 31 | fibvals[2] <- 1 32 | for (i in 3:n) { 33 | fibvals[i] <- fibvals[i-1]+fibvals[i-2] 34 | } 35 | #return (tail(fibvals, n=1)) 36 | res_fib3 <<- tail(fibvals, n=1) 37 | } 38 | 39 | 40 | fib4 <- function(n) { 41 | res_fib4 <<- tail( round(((5 + sqrt(5)) / 10) * (( 1 + sqrt(5)) / 2) ** (1:n - 1)), n=1) 42 | } 43 | 44 | fib5 <- function(n){ 45 | res_fib5 <<- fibonacci(n, sequence = FALSE) 46 | } 47 | 48 | 49 | # Test correctness 50 | 51 | start_time1 <- Sys.time() 52 | fib1(n) 53 | end_time1 <- Sys.time() 54 | res1_time <- end_time1 - start_time1 55 | 56 | start_time2 <- Sys.time() 57 | fib2(n) 58 | end_time2 <- Sys.time() 59 | res2_time <- end_time2 - start_time2 60 | 61 | start_time3 <- Sys.time() 62 | fib3(n) 63 | end_time3 <- Sys.time() 64 | res3_time <- end_time3 - start_time3 65 | 66 | start_time4 <- Sys.time() 67 | fib4(n) 68 | end_time4 <- Sys.time() 69 | res4_time <- end_time4 - start_time4 70 | 71 | start_time5 <- Sys.time() 72 | fib5(n) 73 | end_time5 <- Sys.time() 74 | res5_time <- end_time5 - start_time5 75 | 76 | 77 | 78 | res1_time 79 | res2_time 80 | res3_time 81 | res4_time 82 | res5_time 83 | -------------------------------------------------------------------------------- /functions/Random_image_stopifnot.R: -------------------------------------------------------------------------------- 1 | num <-200 2 | len <- 20 3 | 4 | x <- seq((-num)*pi, (num)*pi, length.out = len) 5 | y <- seq((-num)*pi, num*pi, length.out = len) 6 | r <- sqrt(outer(x^2, y^2, "^")) 7 | image(z = z <- sin(r^0.3)*exp(-r/(10)), col = gray.colors(36)) 8 | 9 | 10 | num <- 150 11 | len <-20 12 | pow <- 3 13 | val <- 5 14 | angle <- 'sin' 15 | 16 | stopifnot(angle %in% available_angle) { 17 | x <- y <- seq((-num)*pi, (num)*pi, length.out = len) 18 | r <- sqrt(outer(x^2, y^2, "^")) 19 | image(z = z <- {{angle}}(r^pow)*exp(-r/(val)), col = gray.colors(36)) 20 | image(z, axes = FALSE) 21 | contour(z, add = TRUE, drawlabels = TRUE) 22 | } 23 | 24 | 25 | random_image <- function(num, pow, val,len, angle) { 26 | available_angle <- c('sin', 'cos', 'tan') 27 | stopifnot(angle %in% available_angle) 28 | 29 | x <- y <- seq((-num)*pi, (num)*pi, length.out = len) 30 | r <- sqrt(outer(x^2, y^2, "^")) 31 | image(z = z <- {{angle}(r^pow)*exp(-r/(val)), col = gray.colors(36)) 32 | image(z, axes = FALSE) 33 | contour(z, add = TRUE, drawlabels = TRUE) 34 | } 35 | 36 | # runfun 37 | random_image(0.5,0.1,20,150, cos) 38 | random_image(0.5,10,20,150, sin) 39 | 40 | 41 | 42 | 43 | 44 | # aa <- runif(10,10,kingdom) 45 | 46 | 47 | random_image <- function(num, pow, val,len, angle='sin') { 48 | available_angle <- c('sin', 'cos', 'tan') 49 | stopifnot(angle %in% available_angle) 50 | 51 | x <- y <- seq((-num)*pi, (num)*pi, length.out = len) 52 | r <- sqrt(outer(x^2, y^2, "^")) 53 | image(z = z <- {{angle}}(r^pow)*exp(-r/(val)), col = gray.colors(36)) 54 | image(z, axes = FALSE) 55 | contour(z, add = TRUE, drawlabels = TRUE) 56 | 57 | } 58 | 59 | random_image(10,2,2,1) 60 | 61 | 62 | stopifnot(angle %in% available_angle) { 63 | x <- y <- seq((-num)*pi, (num)*pi, length.out = len) 64 | r <- sqrt(outer(x^2, y^2, "^")) 65 | image(z = z <- {{angle}}(r^pow)*exp(-r/(val)), col = gray.colors(36)) 66 | image(z, axes = FALSE) 67 | contour(z, add = TRUE, drawlabels = TRUE) 68 | } 69 | 70 | 71 | 72 | -------------------------------------------------------------------------------- /functions/ReverseInteger.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # 4 | # Reverse Integer 5 | # 6 | # 7 | # Series: 8 | # Little Useless-useful R functions #43 9 | # Created: November 09, 2022 10 | # Author: Tomaz Kastrun 11 | # Blog: tomaztsql.wordpress.com 12 | # V.1.0 13 | # 14 | # Changelog: 15 | # 16 | ########################################## 17 | 18 | 19 | # Given a signed 32-bit integer x, return x with its digits reversed. 20 | # If reversing x causes the value to go outside the signed 32-bit integer range [-2**31, 2**31 - 1], 21 | # then return 0. 22 | # source: https://leetcode.com/problems/reverse-integer/ 23 | 24 | 25 | reverseInteger <- function(x){ 26 | if ( -2**31 < x & x > 2**31 -1) return(0) #must be inside the integer boundaries 27 | if (x < 0) { 28 | x2 <- x*-1 29 | r_ints <- (rev(strsplit(as.character(x2), "")[[1]])) 30 | } else { 31 | r_ints <- (rev(strsplit(as.character(x), "")[[1]])) 32 | } 33 | r_ints2 <- paste(r_ints, collapse = "") 34 | r_ints2 <- as.numeric(r_ints2) 35 | 36 | 37 | if ( -2**31 < r_ints2 & r_ints2 > 2**31 -1) { 38 | return(0) 39 | } else { 40 | return(r_ints2) 41 | } 42 | } 43 | 44 | ################# 45 | #function check 46 | ################ 47 | 48 | reverseInteger(-4122310) 49 | # [1] -132214 50 | reverseInteger(122310) 51 | # [1] 13221 52 | reverseInteger(12223456789) # returns zero at the beginning 53 | # [1] 0 54 | 55 | reverseInteger(2147483646) # returns zero after reversing the integer 56 | # [1] 0 -------------------------------------------------------------------------------- /functions/RockPaperScissors.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Play Rock-Paper-Scissors with R 4 | # Series: 5 | # Little Useless-useful R functions #8 6 | # Created: November 11, 2020 7 | # Author: Tomaz Kastrun 8 | # Blog: tomaztsql.wordpress.com 9 | # V.1.0 10 | 11 | # Changelog: 12 | # - adding x11() 13 | ########################################### 14 | 15 | 16 | #################################### 17 | ##### Input bet as a function ##### 18 | #################################### 19 | 20 | 21 | play_RPS <- function(bet) { 22 | bets <- c("R","P", "S") 23 | if(bet %in% bets){ 24 | 25 | solution_df <- data.frame(combo=c("RP", "PR", "PS", "SP", "RS", "SR", "PP", "RR", "SS"), win = c("01","10", "01","10", "10", "01", "00","00","00") ) 26 | REngine <- sample(bets,1) 27 | combo <- paste0(REngine,bet, collapse="") 28 | res <-solution_df[ which(solution_df$combo==combo),2] 29 | if (res=="10"){ 30 | res_print <<- print(paste0("You lost. Your bet: ",bet ,". Computer draw: ", REngine), collapse="") 31 | } else if(res=="00"){ 32 | res_print <<-print(paste0("It's a tie! Your bet: ",bet ,". Computer draw: ", REngine), collapse="") 33 | }else { 34 | res_print <<- print(paste0("You win! Your bet: ",bet ,". Computer draw: ", REngine), collapse="") 35 | } 36 | } 37 | else { 38 | print("Please input valid bet!") 39 | } 40 | } 41 | 42 | 43 | # Run test 44 | play_RPS("R") 45 | 46 | 47 | ############################## 48 | ##### Using x11 ############ 49 | ############################## 50 | 51 | 52 | ### Navigating through x11 with play_RPS function 53 | ## Concept/part of code of using x11() function by Darren Tsai 54 | click <- function(rock.paper.scissors=defaultRPS){ 55 | 56 | while(length(place.na)==9){ 57 | mouse.at <- locator(n = 1, type = "o") 58 | x.at <- round(mouse.at$x) 59 | y.at <- round(mouse.at$y) 60 | if(all(is.na(place.na))){ 61 | defaultRPS <<- rock.paper.scissors() 62 | }else if(x.at > 3.5 | x.at < 0.5 | y.at > 3.5 | y.at < 0.5){ 63 | r <<- r + 1 64 | #title(sub=list("Click outside:Quit/inside:Restart", col="black", font=2, cex=2), line=2) 65 | if(r==2){ 66 | dev.off() 67 | break 68 | } 69 | }else{ 70 | if(r==1){ 71 | defaultRPS <<- rock.paper.scissors() 72 | }else{ 73 | if(x.at==1){ res_print <<- play_RPS("R") 74 | title(sub=list(res_print, col="black", font=0.4, cex=2.0), line=2)} 75 | if(x.at==2){ play_RPS("S") 76 | title(sub=list(res_print, col="black", font=0.4, cex=2.0), line=2)} 77 | if(x.at==3){ play_RPS("P") 78 | title(sub=list(res_print, col="black", font=0.4, cex=2.0), line=2)} 79 | } 80 | Sys.sleep(1) 81 | defaultRPS <<- rock.paper.scissors() 82 | } 83 | } 84 | } 85 | 86 | 87 | #### Board 88 | rock.paper.scissors <- function(){ 89 | place.na <<- matrix(1:9, 3, 3) 90 | value <<- matrix(-3, 3, 3) 91 | k <<- 1 ; r <<- 0 92 | image(1:3, 1:3, matrix(1:9, 3, 3), asp=c(1, 1), xaxt="n", yaxt="n", xlab="", ylab="", frame=FALSE, col=c("lightgreen", "lightYellow", "orchid1","lightgreen", "lightYellow", "orchid1","lightgreen", "lightYellow", "orchid1")) 93 | mtext(side=1, line=-10, at=1.0, adj=0, cex=0.9, 'Rock Scissors Paper') #change 94 | title(sub=list("Click here twice to quit!", col="black", font=2, cex=2), line=4) 95 | } 96 | 97 | ### Start with x11 98 | start_game <- function(){ 99 | x11() 100 | defaultRPS <<- rock.paper.scissors() 101 | click() 102 | } 103 | 104 | ######################## 105 | #### Start the game #### 106 | ######################## 107 | 108 | start_game() 109 | 110 | -------------------------------------------------------------------------------- /functions/SQL_R.R: -------------------------------------------------------------------------------- 1 | ######################################### 2 | # 3 | # Using SQL commands with R data-frame 4 | # 5 | ######################################## 6 | 7 | val <- c(22,42,36,80,54) 8 | name <- c("amber","ben","charles","daniel","eva") 9 | lett <- LETTERS[21:25] 10 | 11 | cdf <- data.frame (val, name, lett) 12 | 13 | # get the values across three vectors 14 | cdf[3,] 15 | 16 | 17 | 18 | val2<- c(22,42,36,80,54,44,53,35,76,44,21) 19 | name2 <- c("a2","b2","c2","d2","e2","f2","g2","h2","i2","j2","k2") 20 | lett2 <- LETTERS[15:25] 21 | 22 | cdf2 <- data.frame (val2, name2, lett2) 23 | 24 | 25 | # get the values across three vectors 26 | cdf2[3,] 27 | 28 | 29 | #install.packages("sqldf") 30 | # load sqldf into workspace 31 | library(sqldf) 32 | 33 | # use SQL syntax to get the results from data.frame 34 | sqldf("select * from cdf") 35 | sqldf("select avg(val) AS avg_age from cdf") 36 | 37 | # merge innto single data.frame 38 | new <- sqldf("select 10 as val,'Tom' as name,'Q' as lett") 39 | 40 | #sqldf("insert into cdf(val,name, lett) values ('Tom',10,'Q')") 41 | cdf <- sqldf(c("insert into cdf select * From new", "select * From cdf")) 42 | 43 | cdf 44 | 45 | 46 | #clean 47 | rm(new,lett,name,val) 48 | 49 | cdf[6,] 50 | 51 | iris <- iris 52 | 53 | # using functions 54 | 55 | sqldf("select [Sepal.Width] from iris 56 | where 57 | [Sepal.Width] >= 3.0") 58 | 59 | iris[iris$Sepal.Width >= 3.0,]$Sepal.Width 60 | 61 | library(dplyr) 62 | 63 | iris %>% 64 | select(Sepal.Width) %>% 65 | filter(Sepal.Width>=3.0) 66 | 67 | 68 | 69 | #reshaping data 70 | DF <- data.frame(g = rep(1:2, each = 5), t = rep(1:5, 2), v = 1:10) 71 | t.names <- paste("t", unique(as.character(DF$t)), sep = "_") 72 | a16r <- reshape(DF, direction = "wide", timevar = "t", idvar = "g", varying = list(t.names)) 73 | 74 | a16s <- sqldf("select 75 | g, 76 | sum((t == 1) * v) t_1, 77 | sum((t == 2) * v) t_2, 78 | sum((t == 3) * v) t_3, 79 | sum((t == 4) * v) t_4, 80 | sum((t == 5) * v) t_5 81 | from DF group by g") 82 | 83 | 84 | sqldf("select count(*) as nof_rows 85 | FROM iris AS i1 86 | JOIN iris as i2 87 | ON i1.[Sepal.Width] = i2.[Sepal.Width] 88 | WHERE 89 | i2.[Sepal.Width] >= 3.0") 90 | 91 | 92 | 93 | #inner,outer joins 94 | 95 | sqldf("select * from cdf 96 | join cdf2 97 | on cdf.val = cdf2.val2") 98 | 99 | 100 | sqldf("select * from cdf 101 | WHERE 102 | val IN (SELECT val2 FROM cdf2)") 103 | 104 | 105 | sqldf("select * from cdf 106 | WHERE 107 | val not in (SELECT val2 FROM cdf2)") 108 | 109 | sqldf("select * from cdf2 110 | WHERE 111 | val2 not in (SELECT val FROM cdf)") 112 | 113 | 114 | 115 | # union / union all 116 | sqldf("select val from cdf 117 | union 118 | select val2 from cdf2") 119 | 120 | # limit, order 121 | sqldf("select val from cdf order by val DESC limit 1") 122 | 123 | 124 | 125 | -------------------------------------------------------------------------------- /functions/SelfCommit.R: -------------------------------------------------------------------------------- 1 | #### 2 | ### 3 | ### Code that self commits 4 | ### 5 | #### 6 | library(ggplot2) 7 | 8 | 9 | PlotIris <- function() { 10 | 11 | ggplot(data=iris, aes(x = Sepal.Length, y = Sepal.Width)) + 12 | geom_point(aes(color=Species, shape=Species)) 13 | 14 | system("sudo cd /Users/tomazkastrun/Documents/GitHub/Useless_R_functions/functions && git add SelfCommit.R && git commit -m 'update' && git push", intern = TRUE) 15 | #system("git add SelfCommit.R", intern = TRUE) 16 | #system("git commit -m 'update' ") 17 | #system("git push") 18 | 19 | } 20 | 21 | PlotIris() 22 | -------------------------------------------------------------------------------- /functions/ShortenURL.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | ########################################## 4 | # 5 | # Plotting QR code and URL Shortener 6 | # 7 | # Series: 8 | # Little Useless-useful R functions #40 9 | # Created: June 28, 2022 10 | # Author: Tomaz Kastrun 11 | # Blog: tomaztsql.wordpress.com 12 | # V.1.0 13 | 14 | # Changelog: 15 | # 16 | ########################################### 17 | 18 | 19 | library(jsonlite) 20 | library(httr) 21 | 22 | 23 | # Shorten URL 24 | ShortenURL <- function(URL2Bshort, linkPreview = FALSE) { 25 | 26 | apiCall <- if(linkPreview) {"http://v.gd/create.php?format=json"} else {"http://is.gd/create.php?format=json"} 27 | URLQuery <- list(url = URL2Bshort) 28 | # get request 29 | request <- httr::GET(apiCall, query = URLQuery) 30 | Callcontent <- httr::content(request, as = "text", encoding = "utf-8") 31 | ShortURL <- jsonlite::fromJSON(Callcontent) 32 | 33 | return(ShortURL) 34 | 35 | } 36 | 37 | 38 | # test it! 39 | ShortenURL("https://medium.com/@tomazkastrun/culture-fit-or-culture-add-e89ca0485ed1") 40 | # https://is.gd/YU3c8m 41 | 42 | 43 | # Create QR Code 44 | 45 | library(qrcode) 46 | library(tidyverse) 47 | library(ggplot2) 48 | 49 | text <- 'https://is.gd/YU3c8m' 50 | color <- "green" 51 | 52 | x <- qr_code(text, ecl="L") #'arg' should be one of “L”, “M”, “Q”, “H” 53 | x <- as.data.frame(x) 54 | 55 | 56 | #convert logic to numeric 57 | cols <- sapply(x, is.logical) 58 | x[,cols] <- lapply(x[,cols], as.numeric) 59 | 60 | y = x 61 | y$id <- rownames(y) 62 | 63 | # transpose for ggplot and make factors 64 | y <- gather(y, "key", "val", colnames(y)[-ncol(y)]) 65 | y$key = factor(y$key, levels=rev(colnames(x))) 66 | y$id = factor(y$id, levels=rev(rownames(x))) 67 | 68 | 69 | 70 | ggplot(y, aes(x=id, y=key)) + geom_tile(aes(fill=val)) + theme_void() + theme(legend.position = "none") 71 | -------------------------------------------------------------------------------- /functions/SmallMultipleGraphs.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Small multiple graphs 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #28 7 | # 8 | # Created: September 14, 2021 9 | # Author: Tomaž Kaštrun 10 | # Blog: tomaztsql.wordpress.com 11 | 12 | # Changelog: 13 | ########################################### 14 | 15 | set.seed(2908) 16 | 17 | # 1. Making data of 20 cases 18 | myData <- data.frame(value=rnorm(2000, mean = 40, sd=20)) 19 | myControls <- data.frame(value=rnorm(2000, mean = 30, sd=20)) 20 | cases <- NULL 21 | controls <- NULL 22 | for (i in 1:20) { 23 | cases[[i]] <- sample(myData$value, size=20) 24 | controls[[i]] <- sample(myControls$value, size=20) 25 | } 26 | 27 | estimates <- data.frame(lower=NA, 28 | meanDiff=sapply(cases, mean)-sapply(controls,mean), 29 | caseSSE= sapply(cases, function(x) sum((x-mean(x))^2)), 30 | controlSSE = sapply(controls, function(x) sum((x-mean(x))^2)), 31 | sd=NA, 32 | upper=NA) 33 | 34 | 35 | # Calculating statistics 36 | estimates$sd <- sqrt((estimates$caseSSE+estimates$controlSSE)/64) 37 | se <- estimates$sd/sqrt(32) 38 | tBound <- qt(0.975, df=31) 39 | zBound <-qnorm(0.975) 40 | estimates$lower <- estimates$meanDiff - se*tBound 41 | estimates$upper <- estimates$meanDiff + se*tBound 42 | estimates$problem = estimates$lower >10 | estimates$upper < 10 43 | 44 | 45 | tTest <- mapply(t.test, x=controls, y=cases) 46 | tTest <- as.data.frame(t(tTest)) 47 | estimates$p <- unlist(tTest$p.value) 48 | estimates$p <- round(estimates$p, 4) 49 | estimates$significance <- "" 50 | estimates$significance[estimates$p<.05] <- "*" 51 | estimates$significance[estimates$p<.01] <- "**" 52 | estimates$significance[estimates$p<.001] <- "***" 53 | 54 | estimates$sampleNum <- as.numeric(row.names(estimates)) 55 | popDifferenceSE <- sqrt(20^2+20^2)/sqrt(32) 56 | fakeData<-data.frame(value=rnorm(1000000, mean=10, sd=popDifferenceSE)) 57 | 58 | 59 | 60 | # 2. Get some libs for plotting 61 | 62 | # get libraries we need for plotting and stacking the plots 63 | library(ggplot2) 64 | 65 | 66 | problemColors <- c("TRUE"="red", "FALSE"="blue") 67 | colorScale <- scale_colour_manual(name="problem", values=problemColors) 68 | 69 | 70 | # Plot Graph 71 | ggplot(data=estimates, aes(x=meanDiff, y=sampleNum)) + 72 | 73 | geom_errorbarh(aes(xmin=lower,xmax=upper, color=problem)) + 74 | geom_point(aes(color=problem)) + 75 | geom_vline(xintercept = 10, color="darkgreen") + 76 | scale_y_reverse() + 77 | geom_text(aes(x=-24, y=sampleNum, 78 | label=paste("Mean:", round(meanDiff,2))), 79 | size = 2.5, hjust="inward") + 80 | 81 | geom_text(aes(x=-17, y=sampleNum, 82 | label=paste("P(x): ", 83 | p, sep="")), 84 | size = 2.5, hjust="inward") + 85 | 86 | scale_x_continuous(limits=c(-26,30)) + 87 | colorScale + 88 | theme_void() + 89 | 90 | theme(legend.position = "none", 91 | plot.title = element_text(hjust = 0.65), 92 | plot.margin = unit(c(10, 0, -2, 0), "pt")) + 93 | 94 | ggtitle("Mean with 95% CI") + 95 | geom_text(aes(x=-12, y=sampleNum, 96 | label=estimates$significance), 97 | size = 2.5, hjust="inward") 98 | 99 | 100 | 101 | 102 | 103 | # 4. Clean 104 | rm(popDifferenceSE,i,se,tBound, zBound, cases, controls, myData, myControls, tTest) 105 | rm(colorScale, estimates, fakeData, smallMultiples, finalGraph, problemColors) 106 | 107 | -------------------------------------------------------------------------------- /functions/Spiral_Matrix.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Spiral Matrix 4 | # 5 | # Given a matrix of m ✕n elements (m rows, n columns), 6 | # return all elements of the matrix in spiral order. 7 | # 8 | # Series: 9 | # Little Useless-useful R functions #52 10 | # Created: August 25, 2023 11 | # Author: Tomaz Kastrun 12 | # Blog: tomaztsql.wordpress.com 13 | # V.1.0 14 | # 15 | # Changelog: 16 | # 17 | ########################################## 18 | 19 | 20 | # Helper function 21 | make_matrix <- function(nc,nr){ 22 | 23 | nof <- nc*nr 24 | mat1 <- matrix(sample(1:100, nof, replace=TRUE), ncol=nc, nrow=nr) 25 | return(mat1) 26 | } 27 | 28 | 29 | ## return elements from matrix in spiral order 30 | matrix_spiral <- function(mat) { 31 | mr <- dim(mat)[1] 32 | nc <- dim(mat)[2] 33 | total_len <- mr*nc 34 | 35 | #path #TRUE -> visited; FALSE -> unvisited 36 | visit <- matrix(FALSE, nrow=mr, ncol=nc) 37 | 38 | #helper variables 39 | gor <- 1 40 | dol <- mr 41 | levo <- 1 42 | desno <- nc 43 | res <- vector() 44 | 45 | while (length(res) < total_len) { 46 | 47 | for (i in levo:nc) { 48 | if (!visit[gor, i]) { 49 | res <- c(res, mat[gor,i]) 50 | visit[gor, i] <- TRUE 51 | } } 52 | gor <- gor + 1 53 | 54 | for (i in gor:mr) { 55 | if (!visit[i, desno]) { 56 | res <- c(res, mat[i,desno]) 57 | visit[i, desno] <- TRUE 58 | } } 59 | desno <- desno - 1 60 | 61 | if (gor <= dol) { 62 | for (i in desno:levo) { 63 | if (!visit[dol, i]) { 64 | res <- c(res, mat[dol,i]) 65 | visit[dol, i] <- TRUE 66 | } } 67 | dol <- dol - 1 68 | } 69 | 70 | if (levo <= desno) { 71 | for (i in dol:gor) { 72 | if (!visit[i, levo]) { 73 | res <- c(res, mat[i,levo]) 74 | visit[i, levo] <- TRUE 75 | } } 76 | levo <- levo + 1 77 | } } 78 | return(res) 79 | } 80 | 81 | 82 | # run functions 83 | mat2 <- make_matrix(4,6) 84 | res <- matrix_spiral(mat2) 85 | #res <- matrix_spiral(make_matrix(7,5)) 86 | 87 | #Check results! 88 | if(length(res)==length(mat2)){print("Nice, all elements are incl!")} 89 | print(mat2) 90 | print(res) 91 | -------------------------------------------------------------------------------- /functions/Stats_fun.R: -------------------------------------------------------------------------------- 1 | ############### 2 | ## 3 | ### Functions 4 | ### 5 | ### 6 | ### Stored as file Stats_fun.R 7 | ### Envoke functions in any other file 8 | ### as library(Stats_fun) 9 | ############### 10 | 11 | library(tidyverse) 12 | 13 | groupsum <- function(df, group_vars, sum_vars){ 14 | df %>% 15 | group_by_at(vars(one_of(group_vars))) %>% 16 | summarise_at(vars(one_of(sum_vars)), list(sum = sum, mean = mean)) 17 | } 18 | 19 | # Usage: 20 | # groupsum(mtcars, 21 | # c("carb", "vs"), 22 | # c("cyl", "hp")) 23 | # 24 | # groupsum(mtcars,"cyl", "hp") 25 | 26 | 27 | sum_var <- function(df, var){ 28 | summarise_at(df, vars(one_of(var)), list(sum = sum, mean = mean)) 29 | #summarise_at(df, vars(one_of(var)), sum) 30 | 31 | } 32 | 33 | 34 | # Usage: 35 | # sum_var(mtcars, "cyl") 36 | # 37 | # sum_var(mtcars,c("cyl", "hp")) 38 | 39 | 40 | Spread <- function(x){ 41 | max(x) - min(x) 42 | } 43 | 44 | 45 | # Usage: 46 | # Spread(mtcars$cyl) 47 | # 48 | 49 | 50 | ##### drawing and calling function from a function 51 | 52 | create_brand <- function(cars_df) { 53 | 54 | brands <- sapply( 55 | strsplit(rownames(cars_df), ' '), 56 | '[', 57 | 1 58 | ) 59 | 60 | return (brands) 61 | } 62 | mean_by_variable <- function(df, agg_var, by_var) { 63 | 64 | aggregate_brand <- aggregate( 65 | df[,agg_var], 66 | by = list(df[,by_var]), 67 | FUN = mean 68 | ) 69 | 70 | return (aggregate_brand) 71 | 72 | } 73 | 74 | 75 | plot_sorted_scatter <- function(cars_data, agg_var, by_var) { 76 | 77 | cars_data$brand <- create_brand(cars_data) 78 | 79 | # Create Aggregation 80 | agg_data <- mean_by_variable(cars_data, agg_var, by_var) 81 | 82 | # Sort 83 | sort_order <- factor( 84 | agg_data[order(agg_data[,'x']),]$Group.1 85 | ) 86 | 87 | ggplot( 88 | data = agg_data, 89 | aes(x=factor(Group.1, levels=sort_order), y=x, color='darkred') 90 | ) + geom_point() + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) 91 | 92 | } 93 | -------------------------------------------------------------------------------- /functions/TSQL_2048.sql: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/functions/TSQL_2048.sql -------------------------------------------------------------------------------- /functions/TryCatch_errorHandling.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Playing with TryCatch the error 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #17 7 | # Created: February 02, 2021 8 | # Author: Tomaz Kastrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | 12 | # Changelog: 13 | # 14 | ########################################### 15 | 16 | 17 | sum <- function(a,b){ 18 | #return(a+b) 19 | #print(a+b) 20 | rr <<-a+b 21 | } 22 | 23 | 24 | 25 | sum(2,3) 26 | df_error <- data.frame(error = " ", timestamp = Sys.time() ) 27 | 28 | 29 | sum_error <- function(expr){ 30 | res_try <- tryCatch(expr, 31 | error = function(e){ 32 | #message("Vrni napako ", e) 33 | print(1) 34 | ee <<- e 35 | 36 | }, 37 | warning = function(w){ 38 | #message("Vrni sporočilo:", w) 39 | print(0) 40 | }) 41 | if (res_try != 1){ 42 | print(0) 43 | } else { 44 | df_error <- rbind(df_error, data.frame(error=ee$message, timestamp = Sys.time())) 45 | } 46 | 47 | } 48 | 49 | 50 | # testing 51 | 52 | sum_error(sum(2,"3")) 53 | 54 | sum_error(sum(2,5)) 55 | 56 | 57 | 58 | 59 | 60 | -------------------------------------------------------------------------------- /functions/TwoSum_CanSum.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # 4 | # Solution with O(n) Time and O(n) Space with 5 | # R on for CanSum() problem 6 | # 7 | # Series: 8 | # Little Useless-useful R functions #43 9 | # Created: October 15, 2022 10 | # Author: Tomaz Kastrun 11 | # Blog: tomaztsql.wordpress.com 12 | # V.1.0 13 | # 14 | # Changelog: 15 | # 16 | ########################################## 17 | 18 | 19 | 20 | ## Using Brute Force 21 | #' Each step of the subtree will be calculated again 22 | 23 | canSumBF <- function(target, numbers){ 24 | if (target == 0) { return (TRUE) } 25 | if (target < 0){ return (FALSE) } 26 | 27 | for (i in 1:length(numbers)){ 28 | remainder <- target - numbers[i] 29 | if (canSumBF(remainder, numbers) == TRUE) { 30 | return (TRUE) 31 | } 32 | } 33 | return(FALSE) 34 | } 35 | 36 | 37 | #combo test 38 | canSumBF(7, c(2,3,5)) ## true 39 | canSumBF(8, c(5,3,4,7)) ## true 40 | canSumBF(87, c(13,10)) ## false 41 | canSumBF(250, c(7,14)) ## false ... takes cca 45 sec :) 42 | 43 | 44 | ## Using memos for intermediate states 45 | #' Calling recursive function and store 46 | #' intermediate states of subtree calculations 47 | #' to diminish the number of recursions 48 | canSumMEMO <- function(target, numbers, memo = list()){ 49 | if (target == 0) { return (TRUE) } 50 | if (target < 0) { return (FALSE) } 51 | if (target %in% names(memo)) { 52 | return (memo[[as.character(target)]]) 53 | } 54 | 55 | for (i in 1:length(numbers)){ 56 | remainder <- target - numbers[i] 57 | # Fixed version to emulate behaviour of canSumBF 58 | if (canSumMEMO(remainder, numbers, memo) == TRUE) { 59 | #if (canSumMEMO(remainder, numbers[i], memo) == TRUE) { 60 | memo[[as.character(target)]] <- TRUE 61 | return (TRUE) 62 | } 63 | } 64 | memo[[as.character(target)]] <- FALSE; 65 | return(FALSE) 66 | 67 | } 68 | 69 | # test memo 70 | canSumMEMO(250, c(7,14)) ## false ...superfast :) 71 | canSumMEMO(150, c(7,14)) ## false 72 | canSumMEMO(8, c(5,3,4,7)) ## true 73 | 74 | 75 | 76 | 77 | 78 | ########## compare both solutions 79 | 80 | startBF <- Sys.time() 81 | canSumBF(250, c(7,14)) 82 | endBF <- Sys.time() 83 | timeBF <- endBF - startBF 84 | 85 | startMEMO <- Sys.time() 86 | canSumMEMO(250, c(7,14)) 87 | endMEMO <- Sys.time() 88 | timeMEMO <- endMEMO - startMEMO 89 | 90 | -------------------------------------------------------------------------------- /functions/UselessFun_API.R: -------------------------------------------------------------------------------- 1 | # UselessFun_API.R 2 | 3 | #* Vrne sporocilo iz vhoda 4 | #* @param msg Sporocilo za prikaz 5 | #* @get /sporocilce 6 | function(msg1="", msg2="") { 7 | list(paste0("Sporocilce 1 je: '", msg1, "'", " in sporocilce 2 je: '", msg2, "'")) 8 | } 9 | 10 | #* Izrise histogram 11 | #* @serializer png 12 | #* @get /diagram 13 | function() { 14 | library(ggplot2) 15 | rand <- rnorm(100) 16 | hist(rand) 17 | } 18 | 19 | #* Vrne zmnozek dveh cifr 20 | #* @param a Prva stevka za multiply 21 | #* @param b Druga stevka za multiply 22 | #* @get /produkt 23 | function(a="", b="") { 24 | res <- as.numeric(a) * as.numeric(b) 25 | list(paste0("The result is ", res)) 26 | } 27 | 28 | 29 | #* Vrne zmnozek dveh cifr 30 | #* @param a Prva stevka za multiply 31 | #* @param b Druga stevka za multiply 32 | #* @post /prod 33 | function(a, b) { 34 | as.numeric(a) * as.numeric(b) 35 | } 36 | 37 | 38 | 39 | -------------------------------------------------------------------------------- /functions/UselessSort.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | ################################### 4 | # 5 | # Useless R functions 6 | # Sort of sort functions 7 | # 8 | ################################### 9 | 10 | series <- c(65,963,12,-256,529,57,12,778, 0, 54,333,-12345,12, 1,43423,5,7786,43,23,5,67,9098,5,33,22) 11 | 12 | ### Simple sort function 13 | sort(series, decreasing = FALSE) 14 | 15 | 16 | ### Simple sorting with recursion 17 | ## Quick sort moves sorted data to left, right 18 | 19 | quacksort <- function(setN){ 20 | if(length(setN)<=1 | length(setN)==0) { 21 | return(setN) 22 | } else { 23 | home <- setN[1] 24 | rest <- setN[-1] 25 | rest_set <- rest[rest > home] 26 | home_set <- rest[rest <= home] 27 | rest_set <- quacksort(rest_set) 28 | home_set <- quacksort(home_set) 29 | return((c(home_set,home,rest_set))) 30 | } 31 | } 32 | 33 | #series 34 | quacksort(series) 35 | 36 | ### Insert sort 37 | Intosort <- function(A){ 38 | for (j in 2:length(A)) { 39 | key = A[j] 40 | i = j - 1 41 | while (i > 0 && A[i] > key) { 42 | A[(i + 1)] = A[i] 43 | i = i - 1 44 | } 45 | key <- A[(i + 1)] 46 | } 47 | A 48 | } 49 | 50 | Intosort(series) 51 | 52 | 53 | 54 | # social distancing sort :-) 55 | # Like bubble but with distance 56 | 57 | SocialDistancing_sort = function(ser) { 58 | stevec <- 0 59 | 60 | while(TRUE) { 61 | stev_menjava <- 0 62 | for (j in 1 : (NROW(ser) - stevec - 1)) { 63 | if (ser[j] > ser[j + 1]) { 64 | s <- ser[j] 65 | ser[j] <- ser[j+1] 66 | ser[j+1] <- s 67 | stev_menjava =+ 1 68 | } 69 | 70 | } 71 | stevec =+ 1 72 | 73 | if(stev_menjava == 0) break 74 | } 75 | cat(ser) 76 | } 77 | 78 | SocialDistancing_sort(series) 79 | 80 | -------------------------------------------------------------------------------- /functions/Useless_API.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Useless API 4 | # Series: 5 | # Little Useless-useful R functions #23 6 | # Created: April 8, 2021 7 | # Author: Tomaž Kaštrun 8 | # Blog: tomaztsql.wordpress.com 9 | # V.1.0 10 | # 11 | # Changelog: 12 | # 13 | ########################################### 14 | 15 | 16 | #install.packages("plumber", dependencies=TRUE) 17 | 18 | old <- getwd() 19 | path <- "Users/tomazkastrun/Documents/GitHub/Useless_R_functions/functions" 20 | 21 | library(plumber) 22 | 23 | 24 | 25 | plumb("Documents/GitHub/Useless_R_functions/functions/UselessFun_API.R") %>% 26 | pr_run(port=2908) 27 | 28 | ### Get 29 | # Url1: http://127.0.0.1:2908/sporocilce?msg1=aaaa&msg2=bbbb 30 | # Url2: http://127.0.0.1:2908/diagram 31 | # Url3: http://127.0.0.1:2908/produkt?a=2&b=3 32 | 33 | 34 | ### Post 35 | #Url4: http://127.0.0.1:2908/prod?a=4&b=4 36 | -------------------------------------------------------------------------------- /functions/ValentinePoem.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Valentine useless R function Poem 4 | # in a Heart 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #18 8 | # Created: February 07, 2021 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | # 13 | # Changelog: 14 | # - sin + sin = heart 15 | # - cos + cos = angel wings 16 | ########################################### 17 | 18 | library(tidyverse) 19 | 20 | 21 | ValentinePoem <- function(){ 22 | df<- data_frame(sq = seq(-30, 0, 0.005), 23 | x1 = (sin(sq)*sin(sq)), 24 | x2 = x1*-1, 25 | y = sqrt(cos(sq))*cos(200*sq) + sqrt(abs(sq)) - 0.7*(4 - sq^2)^0.01 26 | ) %>% 27 | gather(heart, x,x1,x2) 28 | p <- ggplot(df, aes(x, y)) + geom_polygon(fill = "Red") + theme_void() + 29 | geom_text(size=6,aes(x=0, y=0, label="Errors are red, \n 30 | Reserved words are blue, \n 31 | I am here writing this useless\n 32 | R heart function for you!"), col="black") + theme(legend.position = "none") 33 | return(p) 34 | } 35 | 36 | 37 | # Run function 38 | ValentinePoem() 39 | 40 | 41 | ############################ 42 | ############################ 43 | ## Adding animate function 44 | ## submitted as comment 45 | ## to blog: https://tomaztsql.wordpress.com/2021/02/08/little-useless-useful-r-functions-useless-r-poem-for-valentine/ 46 | ## by Jeff Monroe: https://monroeanalytics.com/ 47 | ## on 08.FEB. 2021 48 | ############################ 49 | ############################ 50 | 51 | 52 | library(ggplot2) 53 | library(gganimate) 54 | library(gifski) 55 | library(data.table) 56 | 57 | gen_heart_y = function(x, a) { 58 | (x^2)^(1 / 3) + 0.9 * (3.3 - x^2)^(1 / 2) * sin(a * pi * x) 59 | } 60 | 61 | heart_dt_list = lapply(seq(1, 25, by = 0.1), function(a) { 62 | heart_dt = data.table(x = seq(-1.8, 1.8, length.out = 500), a = a) 63 | heart_dt[, y := gen_heart_y(x, a)] 64 | return(heart_dt) 65 | }) 66 | 67 | full_heart_dt = rbindlist(heart_dt_list) 68 | 69 | animated_ip_heart = ggplot(full_heart_dt, aes(x, y)) + 70 | geom_line(color='red') + 71 | annotate('text', label = 'Errors are red', x = 0, y = 1, size = 8, colour = 'black') + 72 | annotate('text', label = 'Reserved words are blue', x = 0, y = 0.8, size = 8, colour = 'black') + 73 | annotate('text', label = 'Here is this useless', x = 0, y = 0.6, size = 8, colour = 'black') + 74 | annotate('text', label = 'R function for you', x = 0, y = 0.4, size = 8, colour = 'black') + 75 | theme_void() + 76 | transition_manual(a) 77 | 78 | animation = animate(animated_ip_heart, width = 400, height = 400) 79 | 80 | 81 | animation 82 | 83 | 84 | 85 | 86 | -------------------------------------------------------------------------------- /functions/Vanishing_sentence.R: -------------------------------------------------------------------------------- 1 | 2 | ########################################## 3 | # 4 | # Function for Vanishing sentences 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #66 8 | # Created: January 05, 2025 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | 13 | # Changelog: 14 | ########################################### 15 | 16 | 17 | library(ggplot2) 18 | library(gganimate) 19 | library(tidyr) 20 | library(dplyr) 21 | 22 | 23 | vanishing_sentence <- function(sentence, output_file = NULL, interval = 0.5) { 24 | 25 | words <- unlist(strsplit(sentence, " ")) 26 | vanishing_order <- sample(seq_along(words)) 27 | 28 | sentence_data <- data.frame( 29 | word = words, 30 | position = seq_along(words), 31 | vanish_step = match(seq_along(words), vanishing_order) 32 | ) 33 | 34 | # sequence 35 | animation_data <- do.call(rbind, lapply(1:(max(sentence_data$vanish_step) + 1), function(step) { 36 | sentence_data %>% 37 | mutate(visible = ifelse(vanish_step >= step, TRUE, FALSE)) %>% 38 | group_by(position) %>% 39 | summarize(word = ifelse(visible, word, ""), .groups = "drop") %>% 40 | mutate(step = step) 41 | })) 42 | 43 | p <- ggplot(animation_data, aes(x = position, y = 1, label = word)) + 44 | geom_text(size = 6, hjust = 0.5, vjust = 0.5, fontface = "bold") + 45 | theme_void() + 46 | theme( 47 | plot.margin = margin(1, 1, 1, 1, "cm"), 48 | plot.background = element_rect(fill = "white", color = NA) 49 | ) + 50 | transition_states(step, transition_length = interval,state_length = 1) + 51 | enter_fade() + 52 | exit_fade() + 53 | ease_aes("linear") + 54 | labs(title = "Vanishing Sentence Animation") 55 | 56 | 57 | # render and save 58 | if (!is.null(output_file)) { 59 | anim <- animate( p,nframes = length(words) + 10, fps = 10,width = 800,height = 400, renderer = gifski_renderer(output_file) ) 60 | 61 | message("Animation saved to ", output_file) 62 | return(anim) 63 | } else { 64 | # or view if file is not specified 65 | animate( 66 | p, 67 | nframes = length(words) + 10, 68 | fps = 10, 69 | width = 800, 70 | height = 400 71 | ) 72 | } 73 | } 74 | 75 | 76 | 77 | # Example usage 78 | 79 | 80 | sentence <- "This sentence will gradually vanish - word by word" 81 | # save to file 82 | vanishing_sentence(sentence, output_file = "vanishing_sentence.gif") 83 | # save to output 84 | vanishing_sentence(sentence) 85 | 86 | 87 | -------------------------------------------------------------------------------- /functions/Variables_loop_plot.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Looping through variable names and 4 | # plotting boxplots 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #22 8 | # Created: May 22, 2021 9 | # Author: Tomaž Kaštrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | # 13 | # Changelog: 14 | ########################################### 15 | 16 | library(ggplot2) 17 | 18 | 19 | #get column names from sample dataset Iris 20 | variableR <- names(iris)[1:4] 21 | x <- names(iris)[5] 22 | 23 | # Helper function 24 | Iris_plot <- function(df=iris, x, y) { 25 | ggplot(df, aes(x = !! sym(x), y = !! sym(y) )) + 26 | geom_boxplot(notch = TRUE) + 27 | ggtitle(paste0("Plot of ", y, " with ", x )) + 28 | theme_classic(base_size = 10) 29 | } 30 | 31 | 32 | # Main loop through the columns and dataset 33 | for(varR in variableR){ 34 | name <- paste0(varR, "_x_", x) 35 | png(paste0(name, ".png")) 36 | print(Iris_plot(df=iris, x=x, y=varR)) 37 | dev.off() 38 | } 39 | 40 | 41 | # Comparison with facets 42 | #wrap 43 | ggplot(iris, aes(Sepal.Length, fill = Species)) + 44 | geom_boxplot() + 45 | facet_wrap( ~ Species) 46 | 47 | #grid 48 | ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width, color = Species)) + 49 | geom_point() + 50 | facet_grid(. ~ Species) 51 | -------------------------------------------------------------------------------- /functions/WackyPasswordGenerator.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Generate wacky (strong) password 4 | # Series: 5 | # Little Useless-useful R functions #8 6 | # Created: November 5, 2020 - work in prog 7 | # Author: Tomaz Kastrun 8 | # Blog: tomaztsql.wordpress.com 9 | # V.1.0 10 | 11 | # Changelog: 12 | ########################################### 13 | 14 | Sys.setlocale("LC_CTYPE", "en_US.UTF-8") 15 | 16 | # Running on Linux/MacOS 17 | WackyPassword <- function(WP_length){ 18 | 19 | if (WP_length < 9) { 20 | print("Password must be longer then 8 characters") 21 | return() 22 | } 23 | 24 | if (WP_length > 30) { 25 | print("Wooohooo Cowboy, slow down!") 26 | return() 27 | } 28 | 29 | #charblock1 = c(176:178, 185: 188, 200:206) 30 | charblock1 <- c("\u2591","\u2592","\u2593") 31 | charblock2 = c(73,105,108,124,49,33) 32 | numberblock3 <- sample(0:9, length(5),replace = TRUE) 33 | 34 | pass = "" 35 | Encoding(pass) <- "UTF-8" 36 | ran2 <- floor(sample(1:WP_length/2)) 37 | ran1 <- floor(sample(1:WP_length/2)) 38 | while (nchar(pass) <= WP_length) { 39 | res2 <- sample(charblock2, 100,replace = TRUE) 40 | res2 <- rawToChar(as.raw(res2)) 41 | Encoding(res2) <- "UTF-8" 42 | start2 <- sample(1:90,1) 43 | pass <- paste0(pass,substr(res2,start2,start2+ran2),collapse="", sep= "") 44 | 45 | 46 | res1 <- sample(charblock1, 100,replace = TRUE) 47 | Encoding(res1) <- "UTF-8" 48 | start1 <- sample(20:70,1) 49 | res <- paste0(res1, sep = "", collapse = "") 50 | pass <- paste0(pass,substr(res,start1,start1+ran1), sep="", collapse = "") 51 | } 52 | 53 | cat(eval(substr(pass,1,WP_length))) 54 | } 55 | 56 | 57 | 58 | WackyPassword(18) 59 | 60 | 61 | -------------------------------------------------------------------------------- /functions/Weierstrass_function.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Weierstrass function 4 | # 5 | # 0 < a < 1 6 | # b odd positive integer 7 | # ab > 1 + 3/2 pi 8 | # 9 | # Series: 10 | # Little Useless-useful R functions #53 11 | # Created: September 03, 2023 12 | # Author: Tomaz Kastrun 13 | # Blog: tomaztsql.wordpress.com 14 | # V.1.0 15 | # 16 | # Changelog: 17 | # 18 | ########################################## 19 | 20 | 21 | weierstrass_curve <- function(x,a,b) { 22 | values <- 0 23 | for (n in 0:100) { 24 | values <- values + (a**n * cos(b**n * pi * x)) } 25 | return(values) 26 | } 27 | 28 | len <- 1000 29 | 30 | # x <- seq(-0.4, 0.4, length.out=len) 31 | # y <- weierstrass_curve(x,0.5,5) 32 | x <- seq(-2, 2, length.out=len) 33 | y <- weierstrass_curve(x,0.3,5) 34 | 35 | plot(x, y, type = "l", col = "red", main = "Weierstrass curve") 36 | 37 | 38 | -------------------------------------------------------------------------------- /functions/WordScrambler.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Reading scrambled text 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #9 7 | # Created: December 24, 2020 8 | # Author: Tomaz Kastrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | 12 | # Changelog: 13 | # - 14 | ########################################### 15 | 16 | 17 | #helper function 18 | full_scramble <- function(s_word) { 19 | s_word <- as.character(s_word) 20 | i <- sample(1:nchar(s_word)) 21 | sep_word <- unlist(strsplit(s_word, "")) 22 | paste(sep_word[i], collapse = "") 23 | } 24 | 25 | 26 | WordScrambler <- function(text){ 27 | 28 | Words <- as.list(el(strsplit(Text, " "))) 29 | New_text <- paste0(unlist(sapply(1:length(Words), function(x) full_scramble(Words[x]))), collapse = " ") 30 | 31 | return(tolower(New_text)) 32 | } 33 | 34 | 35 | #Get some sample text 36 | Text <- "This is a successful writting of the quick brown fox jumps over the lazy dog" 37 | 38 | #run the Word Scrambler 39 | WordScrambler(Text) 40 | -------------------------------------------------------------------------------- /functions/all_time_useless.R: -------------------------------------------------------------------------------- 1 | ### some useless sfuutffffll 2 | 3 | 4 | useless_math_function <- function(x) { 5 | if (x <= 0) { 6 | return("Please input positive num.") 7 | } else { 8 | result <- log10(exp(x)) + abs(cos(x)) * sqrt(2) 9 | return(result) 10 | } 11 | } 12 | 13 | 14 | useless_math_function(10) 15 | 16 | 17 | 18 | useless_math_function <- function(length) { 19 | sequence <- c() 20 | for (i in 1:length) { 21 | number <- i^2 + log10(i) + exp(pi) 22 | sequence <- c(sequence, number) 23 | } 24 | return(sequence) 25 | } 26 | 27 | 28 | useless_math_function(10) 29 | 30 | 31 | 32 | useless_math_function <- function(x) { 33 | if (x < 0) { 34 | return(sqrt(abs(sin(x) * log(1 + x^2)))) 35 | } else { 36 | return(cos(exp(log(2 * x + 1)) / sqrt(pi))) 37 | } 38 | } 39 | 40 | useless_math_function(10) 41 | 42 | 43 | 44 | useless_math_function <- function(x) { 45 | if (x %% 2 == 0) { 46 | result <- log10(sqrt(abs(x))) + cos(x) * sin(x) 47 | } else { 48 | result <- exp(x) / (1 + abs(tan(x))) 49 | } 50 | return(result) 51 | } 52 | 53 | 54 | useless_math_function(10) 55 | 56 | 57 | useless_complex_function <- function(n) { 58 | if (n <= 0) { 59 | return(NULL) 60 | } 61 | 62 | matrix_list <- lapply(1:n, function(i) { 63 | matrix(outer(1:i, 1:i, FUN = function(x, y) { 64 | if (x == y) { 65 | return(log(1)) 66 | } else { 67 | return(exp(x) / (x + y)) 68 | } 69 | })) 70 | }) 71 | 72 | result <- array(0, dim = c(n, n, n)) 73 | 74 | for (i in 1:n) { 75 | for (j in 1:n) { 76 | for (k in 1:n) { 77 | result[i, j, k] <- sum(matrix_list[[k]][i, , j]) 78 | } 79 | } 80 | } 81 | 82 | return(result) 83 | } 84 | 85 | 86 | useless_complex_function(15) 87 | -------------------------------------------------------------------------------- /functions/apply.R: -------------------------------------------------------------------------------- 1 | 2 | iris <- iris 3 | #iris <- iris$Species 4 | 5 | lapply(iris, view) 6 | 7 | apply(lapply(iris, view), 2,sum) 8 | 9 | 10 | apply(iris[1:4], 2,sum) 11 | 12 | apply(iris[1:4], 1,sum) 13 | 14 | 15 | # group by apply 16 | library(dplyr) 17 | iris %>% 18 | group_by(Species) %>% 19 | group_map(~ head(.x, 3L)) 20 | -------------------------------------------------------------------------------- /functions/binary_octal_decimal_conversion.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Plotting decimal to binary numbers conversion 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #39 7 | # Created: June 20, 2022 8 | # Author: Tomaz Kastrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | 12 | # Changelog: 13 | # 14 | ########################################### 15 | 16 | 17 | ## Function to convert binary to decimal 18 | bin2dec <- function(bin){ 19 | 20 | bin_ss <- as.numeric(strsplit(as.character(bin),"")[[1]]) 21 | pwr <- c((length(bin_ss)-1):0) 22 | res <- 0 23 | for (i in 1:length(bin_ss)){ 24 | res <- res + bin_ss[i]*(2**pwr[i]) 25 | } 26 | 27 | return(paste("Binary", bin, "is ",res," in decimal")) 28 | } 29 | 30 | 31 | ## Function to convert decimal to binary 32 | dec2bin <- function(dec){ 33 | dec_start <- dec 34 | str <- '' 35 | while (dec > 0) { 36 | if ((dec %% 2)==1){ 37 | str <- paste0(str, '1') 38 | } else { #((dec %% 2)==0) 39 | str <- paste0(str, '0') 40 | } 41 | dec <- floor(dec/2) 42 | } 43 | splits <- strsplit(str, "")[[1]] 44 | reversed <- rev(splits) 45 | f_str <- paste(reversed, collapse = "") 46 | #return(paste("Decimal", dec_start, "is ",f_str," in binary")) 47 | return(f_str) 48 | } 49 | 50 | 51 | # Test 52 | bin2dec(11101100) 53 | dec2bin(236) 54 | 55 | 56 | 57 | 58 | 59 | ### Draw scatter plot for the conversion 60 | df <- data.frame(dec_x = 1, bin_y = 1, digit_length=1) 61 | 62 | for (i in 2:100){ 63 | d <- c(dec_x = i, bin_Y = dec2bin(i), nchar(dec2bin(i))) 64 | df <- rbind(df,d) 65 | } 66 | 67 | # change formats 68 | df$dec_x <- as.numeric(df$dec_x) 69 | df$bin_y <- as.numeric(df$bin_y) 70 | 71 | 72 | 73 | library(ggplot2) 74 | library(cowplot) 75 | 76 | line <- ggplot(df, aes(x=dec_x, y=bin_y, colour=digit_length)) + geom_line() 77 | line2 <- ggplot(df, aes(x=dec_x, y=bin_y)) + geom_line() + geom_smooth() 78 | 79 | plot_grid(line, line2, labels = c("Length of binary digits", "Like a binominal distribution")) 80 | 81 | 82 | -------------------------------------------------------------------------------- /functions/climate_spiral.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # 4 | # Drawing GISS surface temperature 5 | # Climate Spiral 6 | # 7 | # Series: 8 | # Little Useless-useful R functions #53 9 | # Created: May 10, 2023 10 | # Author: Tomaz Kastrun 11 | # Blog: tomaztsql.wordpress.com 12 | # V.1.0 13 | # 14 | # Changelog: 15 | # 16 | ########################################## 17 | 18 | library(ggradar) 19 | library(fmsb) 20 | library(scales) 21 | library(RColorBrewer) 22 | 23 | #data url: https://data.giss.nasa.gov/gistemp/ 24 | # Global-mean monthly, seasonal, and annual means, 1880-present, updated through most recent month: TXT, CSV 25 | 26 | #data txt and preparation 27 | df <-read.csv("Documents/GLB.Ts+dSST.csv",header = TRUE, sep = ",", skip = 1, dec="." )[1:13] 28 | df <- as.data.frame(sapply(df[1:143,], as.numeric)) 29 | df_months <- names(df)[2:13] 30 | df_years <- df$Year 31 | rownames(df) <- df_years 32 | df <- df[,2:13] 33 | 34 | # adding max min 35 | max_min <- data.frame( 36 | Jan = c(1.4, -0.85), Feb = c(1.4, -0.85), Mar = c(1.4, -0.85), 37 | Apr = c(1.4, -0.85), May = c(1.4, -0.85), Jun = c(1.4, -0.85), 38 | Jul = c(1.4, -0.85), Aug = c(1.4, -0.85), Sep = c(1.4, -0.85), 39 | Oct = c(1.4, -0.85), Nov = c(1.4, -0.85), Dec = c(1.4, -0.85) 40 | ) 41 | rownames(max_min) <- c("Max", "Min") 42 | #merging 43 | df <- rbind(max_min, df) 44 | 45 | # Set graphic colors 46 | nb.cols <- length(df_years) 47 | mycolors <- colorRampPalette(brewer.pal(8, "Set2"))(nb.cols) 48 | colors_border <- mycolors 49 | colors_in <- alpha(mycolors, 0.3) 50 | 51 | 52 | for (i in 1:length(df_years)){ 53 | y <- df_years[1:i] 54 | df_tmp <- df[rownames(df)%in%y,1:12] 55 | df_tmp <- rbind(max_min, df_tmp) 56 | radarchart( df_tmp, maxmin=TRUE, axistype=1,seg=3,vlabels = df_months, 57 | plwd=0.5 , plty=1,centerzero=FALSE,caxislabels = c(-1, 0, 1, 1.4), 58 | cglcol="grey", cglty=2, axislabcol="black", 59 | vlcex=1.2, 60 | title= paste0("GISS Surface temperature for years until ", tail(y,1)) ) 61 | legend(x=-0.35, y=0.15, legend = tail(y,1), bty = "n", pch=30 , col=colors_in , text.col ="black", cex=1.3, pt.cex=3) 62 | } 63 | 64 | -------------------------------------------------------------------------------- /functions/confuser_animation.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/functions/confuser_animation.gif -------------------------------------------------------------------------------- /functions/confuser_report.md: -------------------------------------------------------------------------------- 1 | # 📄 Parody Scientific Report 2 | ## Project: **unit_converter_confuser()** 3 | 4 | ### Conversion: `kilograms` ➡️ `bananas` 5 | 6 | **Sample size**: 20 7 | **Conversion factor**: 0.01259 8 | 9 | ### 🔬 T-Test Results: 10 | - t-statistic: 27.575 11 | - p-value: <2e-16 12 | - Conclusion: 🤯 Statistically significant nonsense! 13 | 14 | ### 📉 Plot included in animation. 15 | 16 | _This report is proudly brought to you by the Society of Confused Analysts._ 17 | -------------------------------------------------------------------------------- /functions/custom_pallete.R: -------------------------------------------------------------------------------- 1 | library(ggplot2) 2 | 3 | my_palette <- c("red", "limegreen", "#3357FF", "goldenrod1", "#33FFFF", "brown") 4 | 5 | set.seed(2908) 6 | 7 | # make sample data 8 | data <- data.frame( 9 | x = 1:25, 10 | y = rnorm(25), 11 | group = rep(c("A", "B", "C", "D", "E"), each = 5) 12 | ) 13 | 14 | # scatter 15 | ggplot(data, aes(x = x, y = y, color = group)) + 16 | geom_point(size = 3) + 17 | scale_color_manual(values = my_palette, na.value = "grey45") + 18 | theme_minimal() 19 | 20 | # barchart 21 | ggplot(data, aes(x = x, y = y, color = group, fill=group)) + 22 | geom_bar(stat = "identity") + 23 | scale_color_manual(values = my_palette, na.value = "grey45") + 24 | theme_minimal() 25 | 26 | 27 | # boxplot 28 | ggplot(data, aes(x = x, y = y, fill=group)) + 29 | geom_boxplot() + 30 | scale_color_manual(values = my_palette, na.value = "grey45") + 31 | theme_minimal() 32 | 33 | 34 | data2 <- data.frame( 35 | y = c(2,15,24,9,17,2), 36 | group = LETTERS[1:6]) 37 | ) 38 | 39 | # 3.14chart 40 | ggplot(data2, aes(x='', y=y, fill=group)) + 41 | geom_bar(stat="identity", width=1, colour="white") + 42 | scale_color_manual(values = my_palette, na.value = "grey45") + 43 | coord_polar("y", start=0) + 44 | theme_void() 45 | -------------------------------------------------------------------------------- /functions/digitalClock.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Annoying useless small digital clock 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #26 7 | # Created: September 15, 2021 8 | # Author: Tomaž Kaštrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | 12 | # Changelog: 13 | ########################################### 14 | 15 | 16 | SmallDigitalTime <- function() { 17 | cat("\014") 18 | while(TRUE){ 19 | Sys.sleep(0.1) 20 | cat("\r", strftime(Sys.time(), format="%H:%M:%S")) 21 | } 22 | } 23 | 24 | # Run function / clock 25 | SmallDigitalTime() 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /functions/distro_animation.R: -------------------------------------------------------------------------------- 1 | ## Packages 2 | ## distro animation 3 | 4 | library(ggplot2) 5 | library(gganimate) 6 | library(magick) 7 | 8 | ## Colors 9 | 10 | MyPurple <- "#5B005B" 11 | MyLightP <- "#dfdbdf" 12 | MyLightP2 <- "#f8f4f8" 13 | MyLightP3 <- "#fcfafc" 14 | MyPurple5 <- "#9c669c" 15 | 16 | ## Create Data 17 | 18 | data<- data.frame("value"=c(runif(4000, 0, 20), 19 | rbinom(3000, 20, 0.5) + rnorm(3000, 0, 0.3), 20 | runif(1000, 0, 20), 21 | rbinom(2000, 20, 0.7)+ rnorm(2000, 0, 0.3), 22 | runif(2000, 0, 20), 23 | rbinom(2000, 20, 0.1)+ rnorm(2000, 0, 0.3), 24 | runif(2000, 0, 20)), 25 | "time"=rep(1:4, each = 4000)) 26 | 27 | 28 | ## Create Animated Graphs 29 | 30 | g1 <- ggplot(data, aes(x="",y = value)) + 31 | geom_boxplot(fill = MyPurple5, color = "black",lwd = 1.5, fatten = 1) + 32 | coord_flip() + 33 | geom_jitter(width = 0.25, color = MyPurple, size = 2, alpha = 0.2) + 34 | transition_states(time, transition_length = 3, state_length = 2 ) + 35 | enter_fade() + 36 | exit_fade() + 37 | theme(plot.title=element_text(size=20), 38 | plot.background = element_rect(fill = MyLightP3), 39 | panel.background = element_rect(fill=MyLightP), 40 | panel.grid.major.x = element_blank(), 41 | panel.grid.major.y = element_blank(), 42 | panel.grid.minor.x = element_blank(), 43 | panel.grid.minor.y = element_blank(), 44 | axis.text.y = element_blank(), 45 | axis.ticks = element_blank(), 46 | axis.text.x = element_blank() 47 | ) + 48 | labs(title="Histogram and Boxplot", y = NULL, x = NULL) 49 | 50 | g2 <- ggplot(data, aes(x = value)) + 51 | geom_histogram(bins = 30, fill = MyPurple5, color = "black") + 52 | transition_states(time, transition_length = 3, state_length = 2 ) + 53 | enter_fade() + 54 | exit_fade() + 55 | theme(axis.text = element_text(size = 14), 56 | axis.title = element_text(size = 16), 57 | plot.background = element_rect(fill = MyLightP3), 58 | panel.background = element_rect(fill = MyLightP), 59 | plot.caption = element_text(hjust = c(1), size = c(14), 60 | color = c(MyPurple) ) 61 | ) + 62 | labs(title = NULL, y = NULL, x = NULL, 63 | caption=c("Thanks") ) 64 | 65 | 66 | BoxPlotAnimate <- animate(g1 , fps = 5, duration = 10, 67 | width = 1456 / 2, height = (936 / 2) / 2, 68 | renderer = magick_renderer() ) 69 | 70 | HistPlotAnimate <- animate(g2 , fps = 5, duration = 10, 71 | width = 1456 / 2, height = 3 * (936 / 2) / 4, 72 | renderer = magick_renderer() ) 73 | 74 | ## Combine the two animated graph into one image 75 | 76 | HistBoxAnimate <- image_append(c(BoxPlotAnimate[1],HistPlotAnimate[1]), stack = TRUE) 77 | 78 | for( i in 2:50) { 79 | TempGif <- image_append(c(BoxPlotAnimate[i], HistPlotAnimate[i]), stack = TRUE) 80 | HistBoxAnimate <- c(HistBoxAnimate, TempGif) 81 | } 82 | 83 | 84 | ## Save graph 85 | 86 | anim_save("HistBoxAnimate.gif", HistBoxAnimate) 87 | 88 | getwd() 89 | -------------------------------------------------------------------------------- /functions/entropy_meter.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Entropy-meter 4 | # 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #64 8 | # Created: April 06, 2025 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | 13 | # Changelog: 14 | # 15 | ########################################### 16 | 17 | 18 | 19 | library(ggplot2) 20 | library(dplyr) 21 | library(stringr) 22 | 23 | 24 | 25 | entropy_meter <- function(tweet) { 26 | tweet <- str_to_lower(tweet) %>% str_remove_all("\\s") 27 | chars <- unlist(strsplit(tweet, split = "")) 28 | 29 | freq_table <- table(chars) 30 | probs <- freq_table / sum(freq_table) 31 | 32 | # Shannon entropy 33 | entropy <- -sum(probs * log2(probs)) 34 | 35 | list( 36 | tweet = tweet, 37 | entropy = entropy, 38 | char_probs = data.frame(char = names(probs), prob = as.numeric(probs)) 39 | ) 40 | } 41 | 42 | 43 | tweets <- c( 44 | "hello world!", 45 | "aaaaaaahhhhhhh", 46 | "covfefe", 47 | "orange man with number 47", 48 | "The quick brown fox jumps over the lazy dog.", 49 | "BUY $DOGE 🚀 TO THE MOON!!!" 50 | ) 51 | 52 | results <- lapply(tweets, entropy_meter) 53 | 54 | data.frame( 55 | tweet = tweets, 56 | entropy = sapply(results, function(x) x$entropy) 57 | ) 58 | 59 | 60 | most_chaotic <- results[[which.max(sapply(results, function(x) x$entropy))]] 61 | 62 | ggplot(most_chaotic$char_probs, aes(x = reorder(char, -prob), y = prob)) + 63 | geom_col(fill = "steelblue") + 64 | labs( 65 | title = "Character Distribution of a Tweet", 66 | subtitle = paste("Shannon Entropy:", round(most_chaotic$entropy, 3), "bits"), 67 | x = "Character", 68 | y = "Probability" 69 | ) + 70 | theme_minimal() 71 | 72 | 73 | entropy_meter("The mitochondria is the powerhouse of the cell.") 74 | entropy_meter("LOLOLOLOLOL") 75 | entropy_meter("🤖✨🧠👾🌈🦄") # Emojis count too! 76 | 77 | 78 | 79 | ######### 80 | ### ### ### ### ### ### ### ### 81 | # Or slighttly better - compare 82 | ### ### ### ### ### ### ### ### 83 | 84 | 85 | entropy_meter_compare <- function(tweets) { 86 | compute_entropy <- function(tweet) { 87 | tweet_clean <- tolower(gsub("\\s", "", tweet)) 88 | chars <- unlist(strsplit(tweet_clean, split = "")) 89 | if (length(chars) == 0) return(0) 90 | freq_table <- table(chars) 91 | probs <- as.numeric(freq_table) / sum(freq_table) 92 | entropy <- -sum(probs * log2(probs)) 93 | 94 | return(entropy) 95 | } 96 | 97 | entropy_vals <- sapply(tweets, compute_entropy) 98 | 99 | result <- data.frame( 100 | Tweet = tweets, 101 | `Entropy (bits)` = round(entropy_vals, 3), 102 | check.names = FALSE 103 | ) 104 | 105 | return(result[order(-result$`Entropy (bits)`), ]) 106 | } 107 | 108 | 109 | ### Run function for comparison 110 | entropy_meter_compare(tweets) 111 | 112 | -------------------------------------------------------------------------------- /functions/fireworks.R: -------------------------------------------------------------------------------- 1 | 2 | ########################################## 3 | # 4 | # Tiny fireworks with R for New Year's 2022 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #31 8 | # Created: December 29, 2021 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | 13 | # Changelog: 14 | # - add clean rings? 15 | ########################################### 16 | 17 | library(animation) 18 | 19 | 20 | set.seed(2908) 21 | 22 | 23 | Fireworks <- function(nof_rockets=10) { 24 | if(!is.null(dev.list())) dev.off() 25 | if(!interactive()) return() 26 | 27 | draw.fireworks <- function(x,y,ring) { 28 | plot(x, y, xaxt='n', ann=FALSE, yaxt='n', frame.plot=FALSE, xlim=c(0,50),ylim=c(0,500)) 29 | title(main = "Happy New Year 2022", col.main= "white") 30 | for (i in 1:ring) { 31 | ani.options(interval = 0.25) 32 | color <- sample(rainbow(ring),8, replace=TRUE) 33 | symbols(x,y, circles=0.16+i*1.2,add=T, inches=F, fg=color[i]) 34 | ani.pause() 35 | } 36 | par(new=TRUE) 37 | } 38 | 39 | clear.fireworks <- function(x,y,ring){ 40 | plot(x, y, xaxt='n', ann=FALSE, yaxt='n', frame.plot=FALSE, xlim=c(0,50),ylim=c(0,500)) 41 | for (i in 1:ring) { 42 | ani.options(interval = 0.15) 43 | symbols(x,y, circles=0.16+i*1.2,add=T, inches=F, fg="black") 44 | ani.pause() 45 | } 46 | par(new=TRUE) 47 | } 48 | 49 | NewYear.fireworks <- function(){ 50 | bgcolor <- par("bg") 51 | if (bgcolor == "transparent" | bgcolor == "white") bgcolor <- "black" 52 | par(bg=bgcolor) 53 | 54 | # nof_rockets <- 10 55 | xx <-sample(1:50,nof_rockets) 56 | yy <-sample(1:500,nof_rockets) 57 | ringy <- sample(7:13,nof_rockets, replace = TRUE) 58 | 59 | for (i in 1:nof_rockets){ 60 | 61 | x <- xx[i] 62 | y <- yy[i] 63 | ring <- ringy[i] 64 | draw.fireworks(x,y,ring) 65 | # if you don't want rings disapearing, comment this IF statement 66 | if (i > 1) { 67 | x1 <- xx[i-1] 68 | y1 <- yy[i-1] 69 | ring1 <- ringy[i-1] 70 | clear.fireworks(x1, y1, ring1) 71 | } 72 | } 73 | # if you don't want rings disapearing, comment this IF statement 74 | clear.fireworks(tail(xx,1), tail(yy,1), tail(ringy,1)) 75 | } 76 | NewYear.fireworks() 77 | 78 | } 79 | 80 | 81 | ################## 82 | # Run the function 83 | ################## 84 | 85 | Fireworks(10) 86 | 87 | 88 | 89 | -------------------------------------------------------------------------------- /functions/fun_in_fun.R: -------------------------------------------------------------------------------- 1 | 2 | #svd function 3 | svd_f <- function(x,y,a=2){ 4 | 5 | r <- x*y 6 | b <- as.integer(!is.infinite(x/y)) 7 | 8 | tmp <- data.frame( 9 | a1 = a*b, 10 | a2 = b*r, 11 | a3 = a*r 12 | ) 13 | some_fx <- function(n) { i <- 1:n; 1 / outer(i - 1, i, "+") } 14 | X <- some_fx(y+5)[, 1:5] 15 | s <- svd(X) 16 | D <- diag(s$d) 17 | X2 = s$u %*% D %*% t(s$v) 18 | D2 = t(s$u) %*% X %*% s$v 19 | #kronecker(outer(22,2,"+")) 20 | 21 | mm <- as.matrix(1:10, ncol=2) 22 | #kronecker(outer(2,20,"+")) 23 | kronecker(diag(1,5), mm) 24 | 25 | some_cal <- tmp$a1 * tmp$a2 26 | bb <- list( 27 | "temp_Data"= tmp, 28 | "weights" = some_cal, 29 | "svd_s" = s, 30 | "svd_d" = D, 31 | "a" = a, 32 | "svd_X2" = X2, 33 | "svd_D2" = D2, 34 | "graph" = plot(rs$svd_X2) 35 | 36 | ) 37 | return(bb) 38 | } 39 | 40 | 41 | rs <- svd_f(1,2, a=4) 42 | svd_f(1,2, a=4) 43 | 44 | 45 | 46 | -------------------------------------------------------------------------------- /functions/ggplot_tornado.R: -------------------------------------------------------------------------------- 1 | ### kind of tornado 2 | library(ggplot2) 3 | library(gganimate) 4 | 5 | angle <- 2.0 6 | points <- 1000 7 | 8 | t <- (1:points)*angle 9 | x <- cos(t) 10 | y <- acosh(t) 11 | x2 <- sin(t) 12 | 13 | df <- data.frame(t, x, y,x2) 14 | 15 | p <- ggplot(df, aes(x*t, y*t)) 16 | p <- p + 17 | geom_point(aes(size=t),shape=3,alpha=0.5,color="brown") + 18 | theme(panel.background=element_rect(fill="lightblue"), 19 | panel.grid=element_blank(),axis.ticks.x=element_blank(), 20 | axis.ticks.y=element_blank(),axis.title.x=element_blank(), 21 | axis.title.y=element_blank(),axis.text.x=element_blank(), 22 | axis.text.y=element_blank(),legend.position="none") 23 | 24 | p2 <- ggplot(df, aes(x2*t, y*t)) 25 | p2 <- p2 + 26 | geom_point(aes(size=t),shape=3,alpha=0.5,color="brown") + 27 | theme(panel.background=element_rect(fill="lightblue"), 28 | panel.grid=element_blank(),axis.ticks.x=element_blank(), 29 | axis.ticks.y=element_blank(),axis.title.x=element_blank(), 30 | axis.title.y=element_blank(),axis.text.x=element_blank(), 31 | axis.text.y=element_blank(),legend.position="none") 32 | 33 | 34 | animation = animate(c(p,p2), width = 400, height = 400) 35 | animation 36 | -------------------------------------------------------------------------------- /functions/happyDino_head.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/functions/happyDino_head.png -------------------------------------------------------------------------------- /functions/happy_dino.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Happy Dino graph 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #38 7 | # Created: May 25, 2022 8 | # Author: Tomaz Kastrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | 12 | # Changelog: 13 | # 14 | ########################################### 15 | 16 | setwd("/users/tomazkastrun/Documents/tomaztk_github/Useless_R_functions/functions") 17 | 18 | library(ggplot2) 19 | library(magick) 20 | library(cowplot) 21 | 22 | stegosaurus <- data.frame(id = c(1,2,3,4,5,6,7,8,9,10,1,2,3,4,5,6,7,8,9,10), 23 | gr = c("a","a","a","a","a","a","a","a","a","a","b","b","b","b","b","b","b","b","b","b") 24 | ,v = c(1,4,10,18,30,23,15,12,2,0,0,1,10,14,35,39,28,10,8,2) ) 25 | 26 | p <- ggplot(stegosaurus, aes(x=id, y=v, fill=gr)) + 27 | geom_bar(stat = "identity", position="stack") + 28 | theme_void() + 29 | theme(legend.position="none") 30 | 31 | ggdraw() + 32 | draw_image("happyDino_head.png", x = -0.35, y = -0.35, scale = .4) + 33 | draw_plot(p) 34 | 35 | -------------------------------------------------------------------------------- /functions/image_with_image.R: -------------------------------------------------------------------------------- 1 | library(magick) 2 | 3 | 4 | num <- 150 5 | len <-20 6 | pow <- 3 7 | val <- 5 8 | 9 | 10 | random_image <- function(num, pow, val,len, angle) { 11 | available_angle <- c('sin', 'cos', 'tan') 12 | stopifnot(angle %in% available_angle) 13 | 14 | x <- y <- seq((-num)*pi, (num)*pi, length.out = len) 15 | r <- sqrt(outer(x^2, y^2, "^")) 16 | image(z = z <- {{angle}}(r^pow)*exp(-r/(val)), col = gray.colors(36)) 17 | image(z, axes = FALSE) 18 | contour(z, add = TRUE, drawlabels = TRUE) 19 | } 20 | 21 | # Build 10 images -> save them at .png format 22 | png(file="example%02d.png", width=480, height=480) 23 | par(bg="grey") 24 | for (i in c(10:1, "G0!")){ 25 | plot.new() 26 | #text(.5, .5, i, cex = 6) 27 | random_image(0.5*i,10*i,20,150, sin) 28 | 29 | } 30 | dev.off() 31 | 32 | 33 | # Use image magick 34 | system("magick convert -delay 80 *.png animated_count_down.gif") 35 | 36 | # Remove png files 37 | file.remove(list.files(pattern=".png")) 38 | -------------------------------------------------------------------------------- /functions/install_packages_requirements.R: -------------------------------------------------------------------------------- 1 | ## Install Packages 2 | ## using requirements.txt file 3 | 4 | install_packages <- function(packages = NULL, path_to_requirements_file = NULL) { 5 | packages_file <- "" 6 | if (!is.null(path_to_requirements_file)) { 7 | con <- file(path_to_requirements_file) 8 | packages_file <- readLines(con = con, warn = FALSE) 9 | close(con) 10 | } 11 | 12 | # if (length(packages) == 1) {packages <- strsplit(packages, split = "\n")[[1]]} 13 | packages <- c(packages, packages_file) 14 | packages <- packages[!grepl(pattern = "^(#)", x = packages)] 15 | packages <- packages[nchar(packages) > 0] 16 | packages <- unique(packages) 17 | print(packages) 18 | 19 | # for (package in packages) { 20 | # cat(paste0( 21 | # "\n\n## Starting to install '", 22 | # package, 23 | # "' with all dependencies:\n" 24 | # )) 25 | # if (grepl(pattern = "/", x = package)) { 26 | # if (grepl(pattern = "@", x = package)) { 27 | # branch <- gsub(pattern = "^(.*)@",replacement = "",x = package) 28 | # remotes::install_github(repo = package, ref = branch) 29 | # } else { 30 | # remotes::install_github(repo = package) 31 | # } 32 | # } else { 33 | # remotes::update_packages(packages = package, build_manual = FALSE, quiet = TRUE, upgrade = "always") 34 | # } 35 | # } 36 | } 37 | 38 | 39 | path_to_req.txt <- "/Users/tomazkastrun/Documents/tomaztk_github/Useless_R_functions/functions/requirements.txt" 40 | install_packages(path_to_requirements_file = path_to_req.txt) 41 | 42 | # Check the requirements.txt file 43 | ## --------------------- 44 | ## ggplot 45 | ## caret 46 | ## leaflet 47 | ## plotly -------------------------------------------------------------------------------- /functions/iris_py.py: -------------------------------------------------------------------------------- 1 | import pandas as pd 2 | d = {'Sepal.Length':[5.1,4.9,4.7,4.6,5,5.4,4.6,5,4.4,4.9,5.4,4.8,4.8,4.3,5.8,5.7,5.4,5.1,5.7,5.1,5.4,5.1,4.6,5.1,4.8,5,5,5.2,5.2,4.7,4.8,5.4,5.2,5.5,4.9,5,5.5,4.9,4.4,5.1,5,4.5,4.4,5,5.1,4.8,5.1,4.6,5.3,5,7,6.4,6.9,5.5,6.5,5.7,6.3,4.9,6.6,5.2,5,5.9,6,6.1,5.6,6.7,5.6,5.8,6.2,5.6,5.9,6.1,6.3,6.1,6.4,6.6,6.8,6.7,6,5.7,5.5,5.5,5.8,6,5.4,6,6.7,6.3,5.6,5.5,5.5,6.1,5.8,5,5.6,5.7,5.7,6.2,5.1,5.7,6.3,5.8,7.1,6.3,6.5,7.6,4.9,7.3,6.7,7.2,6.5,6.4,6.8,5.7,5.8,6.4,6.5,7.7,7.7,6,6.9,5.6,7.7,6.3,6.7,7.2,6.2,6.1,6.4,7.2,7.4,7.9,6.4,6.3,6.1,7.7,6.3,6.4,6,6.9,6.7,6.9,5.8,6.8,6.7,6.7,6.3,6.5,6.2,5.9,5.9], 3 | 'Sepal.Width':[3.5,3,3.2,3.1,3.6,3.9,3.4,3.4,2.9,3.1,3.7,3.4,3,3,4,4.4,3.9,3.5,3.8,3.8,3.4,3.7,3.6,3.3,3.4,3,3.4,3.5,3.4,3.2,3.1,3.4,4.1,4.2,3.1,3.2,3.5,3.6,3,3.4,3.5,2.3,3.2,3.5,3.8,3,3.8,3.2,3.7,3.3,3.2,3.2,3.1,2.3,2.8,2.8,3.3,2.4,2.9,2.7,2,3,2.2,2.9,2.9,3.1,3,2.7,2.2,2.5,3.2,2.8,2.5,2.8,2.9,3,2.8,3,2.9,2.6,2.4,2.4,2.7,2.7,3,3.4,3.1,2.3,3,2.5,2.6,3,2.6,2.3,2.7,3,2.9,2.9,2.5,2.8,3.3,2.7,3,2.9,3,3,2.5,2.9,2.5,3.6,3.2,2.7,3,2.5,2.8,3.2,3,3.8,2.6,2.2,3.2,2.8,2.8,2.7,3.3,3.2,2.8,3,2.8,3,2.8,3.8,2.8,2.8,2.6,3,3.4,3.1,3,3.1,3.1,3.1,2.7,3.2,3.3,3,2.5,3,3.4,3,3], 4 | 'Petal.Length':[1.4,1.4,1.3,1.5,1.4,1.7,1.4,1.5,1.4,1.5,1.5,1.6,1.4,1.1,1.2,1.5,1.3,1.4,1.7,1.5,1.7,1.5,1,1.7,1.9,1.6,1.6,1.5,1.4,1.6,1.6,1.5,1.5,1.4,1.5,1.2,1.3,1.4,1.3,1.5,1.3,1.3,1.3,1.6,1.9,1.4,1.6,1.4,1.5,1.4,4.7,4.5,4.9,4,4.6,4.5,4.7,3.3,4.6,3.9,3.5,4.2,4,4.7,3.6,4.4,4.5,4.1,4.5,3.9,4.8,4,4.9,4.7,4.3,4.4,4.8,5,4.5,3.5,3.8,3.7,3.9,5.1,4.5,4.5,4.7,4.4,4.1,4,4.4,4.6,4,3.3,4.2,4.2,4.2,4.3,3,4.1,6,5.1,5.9,5.6,5.8,6.6,4.5,6.3,5.8,6.1,5.1,5.3,5.5,5,5.1,5.3,5.5,6.7,6.9,5,5.7,4.9,6.7,4.9,5.7,6,4.8,4.9,5.6,5.8,6.1,6.4,5.6,5.1,5.6,6.1,5.6,5.5,4.8,5.4,5.6,5.1,5.1,5.9,5.7,5.2,5,5.2,5.4,5.1,5.1], 5 | 'Petal.Width':[0.2,0.2,0.2,0.2,0.2,0.4,0.3,0.2,0.2,0.1,0.2,0.2,0.1,0.1,0.2,0.4,0.4,0.3,0.3,0.3,0.2,0.4,0.2,0.5,0.2,0.2,0.4,0.2,0.2,0.2,0.2,0.4,0.1,0.2,0.2,0.2,0.2,0.1,0.2,0.2,0.3,0.3,0.2,0.6,0.4,0.3,0.2,0.2,0.2,0.2,1.4,1.5,1.5,1.3,1.5,1.3,1.6,1,1.3,1.4,1,1.5,1,1.4,1.3,1.4,1.5,1,1.5,1.1,1.8,1.3,1.5,1.2,1.3,1.4,1.4,1.7,1.5,1,1.1,1,1.2,1.6,1.5,1.6,1.5,1.3,1.3,1.3,1.2,1.4,1.2,1,1.3,1.2,1.3,1.3,1.1,1.3,2.5,1.9,2.1,1.8,2.2,2.1,1.7,1.8,1.8,2.5,2,1.9,2.1,2,2.4,2.3,1.8,2.2,2.3,1.5,2.3,2,2,1.8,2.1,1.8,1.8,1.8,2.1,1.6,1.9,2,2.2,1.5,1.4,2.3,2.4,1.8,1.8,2.1,2.4,2.3,1.9,2.3,2.5,2.3,1.9,2,2.3,1.8,1.8], 6 | 'Species':['setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','setosa','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','versicolor','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica','virginica']} 7 | df=pd.DataFrame(data=d) -------------------------------------------------------------------------------- /functions/knapsack_v2.R: -------------------------------------------------------------------------------- 1 | knapsack <- function(values, weights, n, W) { 2 | # Initialize matrix to store results 3 | m <- matrix(0, nrow = n + 1, ncol = W + 1) 4 | 5 | # Fill the matrix using dynamic programming 6 | for (i in 1:n) { 7 | for (w in 1:W) { 8 | if (weights[i] > w) { 9 | m[i + 1, w] <- m[i, w] 10 | } else { 11 | m[i + 1, w] <- max(m[i, w], m[i, w - weights[i]] + values[i]) 12 | } 13 | } 14 | } 15 | 16 | # Trace back to find the items included in the knapsack 17 | included_items <- integer(n) 18 | k <- W 19 | for (i in n:1) { 20 | if (m[i + 1, k] != m[i, k]) { 21 | included_items[i] <- 1 22 | k <- k - weights[i] 23 | } 24 | } 25 | 26 | # Return the maximum value and the items included 27 | return(list(max_value = m[n + 1, W], included_items = included_items)) 28 | } 29 | 30 | # Example usage 31 | values <- c(60, 100, 120) 32 | weights <- c(10, 20, 30) 33 | n <- length(values) 34 | W <- 50 35 | 36 | solution <- knapsack(values, weights, n, W) 37 | max_value <- solution$max_value 38 | included_items <- solution$included_items 39 | 40 | print(paste("Maximum value:", max_value)) 41 | print("Items included in the knapsack:") 42 | for (i in 1:n) { 43 | if (included_items[i] == 1) { 44 | print(paste("Item", i, "with value", values[i], "and weight", weights[i])) 45 | } 46 | } 47 | 48 | 49 | 50 | ## v2 51 | 52 | values <- c(60, 100, 120) 53 | weights <- c(20, 20, 10) 54 | capacity <- 50 55 | 56 | knapsack <- function(values, weights, capacity) { 57 | n <- length(values) 58 | dp <- matrix(0, nrow = n + 1, ncol = capacity + 1) 59 | 60 | for (i in 1:n) { 61 | for (w in 0:capacity) { 62 | if (weights[i] <= w) { 63 | dp[i + 1, w + 1] <- max(dp[i, w + 1], dp[i, w + 1 - weights[i]] + values[i]) 64 | } else { 65 | dp[i + 1, w + 1] <- dp[i, w + 1] 66 | } 67 | } 68 | } 69 | 70 | return(dp[n + 1, capacity + 1]) 71 | } 72 | 73 | 74 | print(knapsack(values, weights, capacity)) 75 | -------------------------------------------------------------------------------- /functions/mathart.R: -------------------------------------------------------------------------------- 1 | 2 | # Load packages 3 | library(mathart) 4 | #devtools::install_github("marcusvolz/mathart") 5 | library(tidyverse) 6 | 7 | # Set parameters (see mathart::mollusc() documentation for details) 8 | n_s <- 650L 9 | n_t <- 2000L 10 | n <- 1000 11 | alpha <- 82.6 12 | beta <- 1.515 13 | phi <- 14.3 14 | mu <- 0 15 | Omega <- 0 16 | s_min <- -193.8 17 | s_max <- 69.4 18 | A <- 7.031 19 | a <- 2.377 20 | b <- 6.42 21 | P <- 0 22 | W_1 <- 1 23 | W_2 <- 1 24 | N <- 0 25 | L <- 0 26 | D <- 1 27 | theta_start <- 0 28 | theta_end <- 10*pi 29 | 30 | # Generate data 31 | df <- mollusc(n_s = n_s, n_t = n_t, 32 | alpha = alpha, beta = beta, phi = phi, mu = mu, Omega = Omega, s_min = s_min, s_max = s_max, 33 | A = A, a = a, b = b, P = P, W_1 = W_1, W_2 = W_2, N = N, L = L, D = D, 34 | theta_start = theta_start, theta_end = theta_end) 35 | 36 | # Create plot 37 | p <- ggplot() + 38 | geom_point(aes(x, z), df, size = 0.03, alpha = 0.03) + 39 | geom_path(aes(x, z), df, size = 0.03, alpha = 0.03) + 40 | coord_equal() + 41 | theme_blankcanvas(margin_cm = 0) 42 | 43 | p 44 | -------------------------------------------------------------------------------- /functions/multiplication_table.R: -------------------------------------------------------------------------------- 1 | ################ 2 | # multiplication 3 | # table 10x10 4 | ################ 5 | 6 | library(tidyverse) 7 | 8 | tibble(x=1:10, y = 1:10) %>% 9 | complete(x,y) %>% 10 | mutate(prod = x*y) %>% 11 | ggplot( aes(x, y)) + 12 | geom_tile(color = "black") + 13 | geom_text(aes(label = prod), color = "white") + 14 | scale_y_continuous(trans = "reverse") + 15 | coord_fixed() + 16 | theme_bw() + theme_void() 17 | 18 | 19 | 20 | 21 | -------------------------------------------------------------------------------- /functions/requirements.txt: -------------------------------------------------------------------------------- 1 | ggplot 2 | caret 3 | leaflet 4 | plotly 5 | ggplot -------------------------------------------------------------------------------- /functions/reverse_hello_world.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Reverse Hello world 4 | # 5 | # Series: 6 | # Little Useless-useful R functions #55 7 | # Created: March 20, 2024 8 | # Author: Tomaž Kaštrun 9 | # Blog: tomaztsql.wordpress.com 10 | # V.1.0 11 | 12 | # Changelog: 13 | ########################################### 14 | 15 | 16 | # reverse Hello World 17 | hello_world <- function(print){ 18 | if (print == "print"){ 19 | print("Hello World") 20 | } else { 21 | cat("\rWell ...") 22 | } 23 | 24 | } 25 | 26 | 27 | # run reverse function :) 28 | 29 | hello_world("print") 30 | -------------------------------------------------------------------------------- /functions/schedule_builder.R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | 3 | library(combinat) 4 | departments <- c("DEP1", "DEP2", "DEP3", "DEP4", "DEP5", "DEP6") 5 | time_slots <- 5 6 | rooms <- 3 7 | 8 | department_pairs <- combn(departments, 2, simplify = FALSE) 9 | 10 | # seed: 124 converges 11 | # seed: 123 not converge 12 | 13 | set.seed(124) 14 | department_pairs <- sample(department_pairs) 15 | 16 | timetable <- matrix(list(), nrow = time_slots, ncol = rooms) 17 | 18 | can_schedule <- function(pair, slot, room, timetable) { 19 | d1 <- pair[1] 20 | d2 <- pair[2] 21 | for (r in 1:rooms) { 22 | if (length(timetable[[slot, r]]) > 0 && (d1 %in% timetable[[slot, r]] || d2 %in% timetable[[slot, r]])) { 23 | return(FALSE) 24 | } 25 | } 26 | return(TRUE) 27 | } 28 | 29 | 30 | fill_timetable <- function(timetable, department_pairs) { 31 | used_pairs <- rep(FALSE, length(department_pairs)) 32 | 33 | for (slot in 1:time_slots) { 34 | for (room in 1:rooms) { 35 | for (pair_index in 1:length(department_pairs)) { 36 | pair <- department_pairs[[pair_index]] 37 | if (!used_pairs[pair_index] && can_schedule(pair, slot, room, timetable)) { 38 | timetable[[slot, room]] <- pair 39 | used_pairs[pair_index] <- TRUE 40 | break 41 | } 42 | } 43 | } 44 | } 45 | return(timetable) 46 | } 47 | 48 | 49 | timetable <- fill_timetable(timetable, department_pairs) 50 | is_complete <- all(sapply(timetable, length) > 0) 51 | 52 | 53 | if (is_complete) { 54 | schedule <- matrix(NA, nrow = time_slots, ncol = rooms) 55 | for (slot in 1:time_slots) { 56 | for (room in 1:rooms) { 57 | if (length(timetable[[slot, room]]) > 0) { 58 | schedule[slot, room] <- paste(timetable[[slot, room]][1], timetable[[slot, room]][2], sep = ":") 59 | } 60 | } 61 | } 62 | #fancy stuff 63 | schedule <- as.data.frame(schedule) 64 | colnames(schedule) <- paste("Room", 1:rooms, sep = " ") 65 | rownames(schedule) <- paste("Time Slot", 1:time_slots, sep = " ") 66 | print(schedule) 67 | 68 | } else { 69 | print("generate new seed to get schedule") 70 | print(as.data.frame(timetable)) 71 | 72 | } 73 | 74 | 75 | -------------------------------------------------------------------------------- /functions/signature.R: -------------------------------------------------------------------------------- 1 | ########################################## 2 | # 3 | # Creating a "signature" like graph with 4 | # xspline 5 | # 6 | # Series: 7 | # Little Useless-useful R functions #50 8 | # Created: February 01, 2023 9 | # Author: Tomaz Kastrun 10 | # Blog: tomaztsql.wordpress.com 11 | # V.1.0 12 | 13 | # Changelog: 14 | # 15 | ########################################### 16 | 17 | inscrp <- function(rep){ 18 | x <- rnorm(rep) 19 | y <- rnorm(rep) 20 | plot(x,y, pch = 1, col = "white", xaxt='n', yaxt='n', ann=FALSE, frame.plot=FALSE) 21 | xspline(x,y, 1, draw = TRUE, col="blue") 22 | } 23 | ##### run 24 | par(mfrow = c(2,1)) 25 | 26 | inscrp(10) 27 | inscrp(20) 28 | 29 | par(mfrow = c(1,1)) 30 | 31 | 32 | inscrp(40) 33 | -------------------------------------------------------------------------------- /functions/twin_dragon_fractal.R: -------------------------------------------------------------------------------- 1 | 2 | ########################################## 3 | # 4 | # Twin dragon Fractal 5 | # a.k.a. Heighway Dragon Curve with n iterations 6 | # a.k.a. David Knuth dragon 7 | # 8 | # Series: 9 | # Little Useless-useful R functions #51 10 | # Created: June 29, 2024 11 | # Author: Tomaz Kastrun 12 | # Blog: tomaztsql.wordpress.com 13 | # V.1.0 14 | 15 | # Changelog: 16 | # - 17 | ########################################### 18 | 19 | 20 | # Function to generate points using IFS 21 | generate_dragon_curve <- function(iterations) { 22 | # Initial point 23 | points <- complex(real = 0, imaginary = 0) 24 | colors <- c() # Vector to store colors 25 | 26 | # two iterated functions; each for own direction 27 | f1 <- function(z) { (1 + 1i) * z / 2 } 28 | f2 <- function(z) { 1 - (1 - 1i) * z / 2 } 29 | 30 | 31 | # iterate to generate points 32 | for (i in 1:iterations) { 33 | new_points <- vector("complex", length = length(points) * 2) 34 | new_colors <- vector("character", length = length(points) * 2) 35 | for (j in 1:length(points)) { 36 | new_points[2 * j - 1] <- f1(points[j]) 37 | new_colors[2 * j - 1] <- ifelse(i %% 2 == 1, "blue", "red") # Alternating colors 38 | new_points[2 * j] <- f2(points[j]) 39 | new_colors[2 * j] <- ifelse(i %% 2 == 1, "red", "blue") # Alternating colors 40 | } 41 | points <- new_points 42 | colors <- c(colors, new_colors) 43 | } 44 | 45 | return(list(points = points, colors = colors)) 46 | } 47 | 48 | 49 | # Plot the Dragon Curve 50 | plot_dragon_curve <- function(iterations) { 51 | result <- generate_dragon_curve(iterations) 52 | points <- result$points 53 | colors <- result$colors 54 | plot(Re(points), Im(points), type = "p", pch = ".", col = colors, asp = 1, labels=FALSE, yaxt="n", xaxt="n", 55 | xlab = "", ylab = "", main = paste("Heighway Dragon Curve with", iterations, "iterations")) 56 | } 57 | 58 | 59 | plot_dragon_curve(15) 60 | 61 | -------------------------------------------------------------------------------- /functions/useless house.R: -------------------------------------------------------------------------------- 1 | library(ggplot2) 2 | 3 | # Useless function of a house 4 | draw_2d_house <- function() { 5 | ggplot() + 6 | geom_rect(aes(xmin = 1, xmax = 4, ymin = 1, ymax = 4, fill = "lightblue"), color = "black") + 7 | geom_polygon(aes(x = c(0.5, 2.5, 4.5), y = c(4, 6, 4)), fill = "red", color = "black") + 8 | geom_rect(aes(xmin = 2.5, xmax = 3.5, ymin = 1, ymax = 2, fill = "brown"), color = "black") + 9 | 10 | # Draw the window 11 | geom_rect(aes(xmin = 1.5, xmax = 2, ymin = 3, ymax = 3.5, fill = "yellow"), color = "black") + 12 | geom_rect(aes(xmin = 3, xmax = 3.5, ymin = 3, ymax = 3.5, fill = "yellow"), color = "black") + 13 | geom_rect(aes(xmin = 1.5, xmax = 2, ymin = 3.5, ymax = 4, fill = "yellow"), color = "black") + 14 | geom_rect(aes(xmin = 3, xmax = 3.5, ymin = 3.5, ymax = 4, fill = "yellow"), color = "black") + 15 | 16 | coord_fixed(ratio = 1, xlim = c(0, 5), ylim = c(0, 7)) + 17 | theme_void() + theme(legend.position = "none") + ggtitle("This is my house") 18 | } 19 | 20 | # run function 21 | draw_2d_house() 22 | 23 | # Useless function of a house with a tree :) 24 | 25 | draw_2d_house_and_tree <- function() { 26 | ggplot() + 27 | geom_rect(aes(xmin = 1, xmax = 4, ymin = 1, ymax = 4, fill = "lightblue"), color = "black") + 28 | geom_polygon(aes(x = c(0.5, 2.5, 4.5), y = c(4, 6, 4)), fill = "red", color = "black") + 29 | geom_rect(aes(xmin = 2.5, xmax = 3.5, ymin = 1, ymax = 2, fill = "brown"), color = "black") + 30 | geom_rect(aes(xmin = 1.5, xmax = 2, ymin = 3, ymax = 3.5, fill = "yellow"), color = "black") + 31 | geom_rect(aes(xmin = 3, xmax = 3.5, ymin = 3, ymax = 3.5, fill = "yellow"), color = "black") + 32 | geom_rect(aes(xmin = 1.5, xmax = 2, ymin = 3.5, ymax = 4, fill = "yellow"), color = "black") + 33 | geom_rect(aes(xmin = 3, xmax = 3.5, ymin = 3.5, ymax = 4, fill = "yellow"), color = "black") + 34 | 35 | # Treeee 36 | geom_rect(aes(xmin = 5, xmax = 5.5, ymin = 1, ymax = 3, fill = "brown"), color = "black") + 37 | geom_polygon(aes(x = c(4.2, 5.75, 6.75, 3.25), y = c(3, 3.5, 2.5, 2)), fill = "green", color = "black") + 38 | geom_polygon(aes(x = c(4, 4.5, 5.5, 6, 5), y = c(3.5, 4.5, 4.5, 3.5, 3)), fill = "green", color = "green") + 39 | geom_polygon(aes(x = c(4, 4.5, 5.5, 6, 5), y = c(2.5, 3.5, 3.5, 2.5, 2.5)), fill = "green", color = "green") + 40 | 41 | 42 | coord_fixed(ratio = 1, xlim = c(0, 7), ylim = c(0, 7)) + 43 | theme_void() + theme(legend.position = "none") + ggtitle("This is my house and Tree") 44 | } 45 | 46 | draw_2d_house_and_tree() 47 | -------------------------------------------------------------------------------- /functions/vanishing_sentence.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/functions/vanishing_sentence.gif -------------------------------------------------------------------------------- /image/Plot_theme_ggplot2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/image/Plot_theme_ggplot2.png -------------------------------------------------------------------------------- /image/amazonLogo.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/image/amazonLogo.jpg -------------------------------------------------------------------------------- /image/anim_decibel.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/image/anim_decibel.gif -------------------------------------------------------------------------------- /image/appleLogo.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/image/appleLogo.jpg -------------------------------------------------------------------------------- /image/geniLogo.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/image/geniLogo.jpg -------------------------------------------------------------------------------- /image/ljubljana.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/image/ljubljana.jpg -------------------------------------------------------------------------------- /image/ljubljana2.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/image/ljubljana2.jpg -------------------------------------------------------------------------------- /image/myiriscompany.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/image/myiriscompany.png -------------------------------------------------------------------------------- /image/nbalogo.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/image/nbalogo.jpg -------------------------------------------------------------------------------- /image/nikeLogo.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/image/nikeLogo.jpg -------------------------------------------------------------------------------- /image/sparkLogo.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/image/sparkLogo.jpg -------------------------------------------------------------------------------- /image/windowsLogo.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tomaztk/Useless_R_functions/9c58601793565a7f42955bda8ba089edb49dda51/image/windowsLogo.jpg --------------------------------------------------------------------------------